Adding OnChangeExpanded Functionality to TTreeView
Under the VCL, TTreeView has events OnExpanded, OnExpanding, OnCollapsing and OnCollapsed but there’s nothing similar in FireMonkey.
TTreeViewItem has a number of methods which get called when the expanded state changes, but none of these is virtual, and therefore there’s no simple patch to add such support. However the IsExpanded property does change to reflect the state and since this is a trigger property is is possible to hack the styling and animation systems to add the support we need.
Simply put we need to add an animation to the item, give it a duration of 0 (so it fires immediately) and hook into it’s OnFinish event so we know when the animation has run. It doesn’t matter which animation we use so I plumped for a TFloatAnimation, but it does need a valid PropertyName so I used Opacity and used a couple of near identical values so the change shouldn’t be noticed.
There’s one slight fly in the ointment. When IsExpanded changes the only animations run are those of the ‘button’ object from the style, so rather than adding the animation directly to the TTreeViewItem you need to add it to the ‘button’ item extracted from the style by FindStyleResource.
So, we create a custom child of TTreeViewItem and add the above action to ApplyStyle. From there it’s simple to add a suitable event, OnChangeExpanded, and a method to call it.
The unit for the new tree view item is,
unit TreeViewExpanded;
interface
uses FMX.TreeView, Classes;
type TTreeViewItemExpanded = class(TTreeViewItem)
private
FOnChangeExpanded: TNotifyEvent;
protected
procedure ApplyStyle;override;
procedure DoChangeExpanded(Sender: TObject);
published
property OnChangeExpanded: TNotifyEvent read FOnChangeExpanded write FOnChangeExpanded;
end;
implementation
uses FMX.Ani, FMX.Types;
{ TTreeViewItemExpanded }
procedure TTreeViewItemExpanded.ApplyStyle;
var Ani: TFloatAnimation;
O: TFMXObject;
begin
inherited;
O := FindStyleResource('button');
if Assigned(O) then
begin
Ani := TFloatAnimation.Create(O);
Ani.Parent := O;
Ani.Stored := False;
Ani.StartValue := 0.999999999999;
Ani.StopValue := 1;
Ani.PropertyName := 'Opacity';
Ani.Trigger := 'IsExpanded=true';
Ani.TriggerInverse := 'IsExpanded=false';
Ani.Duration := 0;
Ani.OnFinish := DoChangeExpanded;
end;
end;
procedure TTreeViewItemExpanded.DoChangeExpanded(Sender: TObject);
begin
if Assigned(OnChangeExpanded) then
OnChangeExpanded(Self);
end;
end.
And here’s a bit of code from the app to test things out,
procedure TForm1.EVChangeExpanded(Sender: TObject);
var Item: TTreeViewItem;
begin
if Sender is TTreeViewItem then
begin
Item := Sender as TTreeViewItem;
if Item.IsExpanded then
Item.Text := 'Expanded'
else
Item.Text := 'Collapsed';
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var Item: TTreeViewItemExpanded;
begin
Item := TTreeViewItemExpanded.Create(Self);
TreeView1.AddObject(Item);
Item.OnChangeExpanded := EVChangeExpanded;
Item.Text := 'Parent';
Item.AddObject(TTreeViewItemExpanded.Create(Self));
Item.Items[0].Text := 'Child';
end;
Grids Added to The FireMonkey Guide
I’ve recently added a number of article about grids to the FireMonkey Guide.
TGrid
TStringGrid
TColumn
Custom Grid Columns
Create a Column Showing the Row Index
Formatting a Column as Currency
Introducing The FireMonkey Guide
A couple of months ago somebody in the Embarcadero forums asked if there was a book FireMonkey. The short answer to that was no. Come to think of it the long answer was no too. There’s the Embarcadero DocWiki which lists every class, method, property and event in the librar. It’s a great reference, but many of those pages are a little terse and lacking in examples.
And then you have a few of us who are blogging. Writing occasional articles about random parts of FireMonkey. That’s great but a little lacking in coherence, and expecting Google to curate what’s out there isn’t really working out for those new to FMX.
I chewed this over and though maybe it was time to sate that desire I’m told we all have in us to write a book. I could create my very own book about FireMonkey. There’s only two downsides to that. Firstly most technical books never make any money for the author and, secondly, when I looked at how much time I had available to write I figured it would take me a couple of years to get finished and by then the technology would have moved on again.
Plus, of course, it would be too late to help all those clamouring for help right now. And the increasing numbers who will be learning this stuff when the Mobile versions of Delphi are released.
I could change the focus of the blog from in depth techical articles about FireMonkey arcana but again you run into curation problems: blogs simply arean’t a convenient way to learn a technology from start to finish.
But the software I use to run this site, Expression Engine, includes a wiki module. I currently use it for the documentation of MonkeyStyler and other downloads. And what is a wiki if not an online book?
So I have now started writing what I shall call The FireMonkey Guide, or just The Guide which fits better on the website headers and seems rather fitting for a long time Douglas Adams fan. This will be a work in progress for a very long time, so you’ll have to put up with some gaping holes for a while, but I hope it will become a useful resource for Delphi whether you want to read it from start to finish or odd pages which Google points you to it on a web search.
Currently uploaded are the obligatory introduction pages, an Introduction to FireMonkey, TFMXObject and TAnimation and it’s children. TAnimation also comes with a handy Interpolation and AnimationType Illustrated guide with nice pictures of what all those animation types actually do. I hope you’ll find it saves time testing different interpolations to see which does what.
At present I’m still finding my way with style and depth of content so please do comment on what you like and don’t like about what I’m writing and the mistakes which, history tells me, will be creeping in along the way.
Enjoy.
A FireMonkey Grid Column for any Control
One of the great things about a FireMonkey grid is that each column can contain any control class. The downside is that to do so you need to go to a certain amount of work.
Wouldn’t it be nice if there was an easy was to create a column for any class of control? Imagine doing this with generics so you could simply say
Grid1.AddObject(TGenericColumn<TCalendarEdit>.Create(Grid1);
If so, read on, you’re in for a fun ride through FireMonkey, generics and RTTI.
TGenericColumn
Here’s our class definition. Really simple.
type TGenericColumn<T: TStyledControl> = class(TColumn)
private
FOnCellCreated: TCellCreatedEvent;
protected
function CreateCellControl: TStyledControl;override;
public
procedure DoChanged(Sender: TObject);
published
property OnCellCreated: TCellCreatedEvent read FOnCellCreated write FOnCellCreated;
end;
We simply subclass TColumn (which by default gives us a column of TEdits. Sadly there’s not an abstract TGenericColumn class available, which would have been a more appropriate better parent).
In our type declaration we specify
so the compiler will validate that we get a descendant of TStyledControl when the class is instantiated. Since a grid cell can be any descendant of TStyledControl this verifies we will be using an appropriate component class.
We override CreateCellControl to do the work of creating the control,
function TGenericColumn<T>.CreateCellControl: TStyledControl;
begin
Result := TStyledControlClass(T).Create(Self);
if Assigned(OnCellCreated) then
OnCellCreated(Self, Result);
end;
CreateCellControl needs to do two things. First it needs to create the control, then it needs to set handlers for any OnChange events of the control so that it can let the grid know when the controls data value changes. The grid will then fire it’s OnSetValue event so the app can monitor the state of the grid. CreateCellControl can also set any properties of the cell which are needed.
The first line creates the control. We can’t directly call create on T, instead we need to get the class for it. We cast T to TStyledControlClass do do this, which means we need to declare TStyledControlClass in the interface of the unit,
type TStyledControlClass = class of TStyledControl;
Assigning event handlers is a difficult one. We don’t know which class is being created, so we don’t know what it’s OnChange event handler(s) may be called. And there’s no common ancestor with an OnChange property.
Instead I created an OnCellCreated event. This is called after creation and enables us to add event handlers and set properties as necessary.
Which brings us to the DoChanged event handler. This is where any change events need to be pointed to and it simply calls the DoTextChanged method of TColumn which in turn handles updating the grid.
procedure TGenericColumn<T>.DoChanged(Sender: TObject);
begin
DoTextChanged(Sender);
end;
Using the Column
So now we can start using the column. We need to create the column(s),
procedure TForm1.FormCreate(Sender: TObject);
begin
Data := TList<TList<TValue>>.Create;
DefaultData := TList<TValue>.Create;
Grid1.AddObject(TGenericColumn<TCalendarEdit>.Create(Self));
TGenericColumn<TCalendarEdit>(Grid1.Columns[0]).OnCellCreated := EVCellCreated;
Grid1.AddObject(TGenericColumn<THueTrackBar>.Create(Self));
TGenericColumn<THueTrackBar>(Grid1.Columns[1]).OnCellCreated := EVCellCreated;
end;
And handle the OnCellCreated events,
procedure TForm1.EVCellCreated(Sender: TObject; var Cell: TStyledControl);
begin
if Cell is TCalendarEdit then
TCalendarEdit(Cell).OnChange := TGenericColumn<TCalendarEdit>(Grid1.Columns[0]).DoChanged;
if Cell is THueTrackBar then
THueTrackBar(Cell).OnChange := TGenericColumn<THueTrackBar>(Grid1.Columns[1]).DoChanged;
end;
It all works nicely, but that code is not easy to read. And all it’s doing in these examples is setting the OnChange event handler of the cell control. Let’s have another look at setting the event automatically.
Bring on RTTI
Whilst we can’t guarantee it, most controls simply have an event named OnChange of type TNotifyEvent which is the only event we need to plug into. So, all we need is to get CreateCellControl to look inside the control for an OnChange event and point it to DoChanged. And this is exactly the type of thing which RTTI was invented for.
Here’s our new CreateCellControl,
function TGenericColumn<T>.CreateCellControl: TStyledControl;
var
C: TRTTIContext;
RT: TRTTIType;
P: TRTTIProperty;
PT: TRTTIType;
begin
Result := TStyledControlClass(T).Create(Self);
A TRTTIContext gives us access to RTTI features. It’s a record, so there’s no need to free it.
C := TRTTIContext.Create;
We get a TRTTIType for our class
RT := C.GetType(Result.ClassInfo);
if RT <> nil then
begin
We find the OnChange property.
P := RT.GetProperty('OnChange');
if P <> nil then
begin
We validate the property is of the correct type.
if P.PropertyType.QualifiedName = 'System.Classes.TNotifyEvent' then
begin
And finally we set the property value for our instance.
P.SetValue(Result, TValue.From<TNotifyEvent>(DoChanged));
end;
end;
end;
if Assigned(OnCellCreated) then
OnCellCreated(Self, Result);
end;
58 Lines
‘Simples’ as they say on an advert over here. And the whole thing was achieved in only 58 lines of code!
Now it does have the disadvantage that you need to create the columns in code, rather than in the form editor. It would theoretically be possibly to have a string property to specify the class and create the cells from that (another bit of fun advanced Delphi coding) but I could forsee problems with creation order. I.e. The column would be created before the CellClass property was set (or changed) and there would need to be a way to change all the cells already created. I’ll leave that as a challenge for another day.
And if you’re interested the rest of the code in the sample app is there to store and retrieve the cell values for the grid’s OnSetValue and OnGetValue events. Which brings to mind an idea to create a grid class which could take any column class and store it’s own values in the same way that a TStringGrid does with strings. Another project for a rainy winters day.
Download the full source: 
Full Source
unit GridColumns;
interface
uses FMX.Grid, FMX.Types;
type TStyledControlClass = class of TStyledControl;
type TCellCreatedEvent = procedure(Sender: TObject;var Cell:TStyledControl) of object;
type TGenericColumn<T: TStyledControl> = class(TColumn)
private
FOnCellCreated: TCellCreatedEvent;
protected
function CreateCellControl: TStyledControl;override;
public
procedure DoChanged(Sender: TObject);
published
property OnCellCreated: TCellCreatedEvent read FOnCellCreated write FOnCellCreated;
end;
implementation
uses RTTI, Classes;
{ TGenericColumn<T> }
function TGenericColumn<T>.CreateCellControl: TStyledControl;
var
C: TRTTIContext;
RT: TRTTIType;
P: TRTTIProperty;
PT: TRTTIType;
begin
Result := TStyledControlClass(T).Create(Self);
C := TRTTIContext.Create;
RT := C.GetType(Result.ClassInfo);
if RT <> nil then
begin
P := RT.GetProperty('OnChange');
if P <> nil then
begin
if P.PropertyType.QualifiedName = 'System.Classes.TNotifyEvent' then
begin
P.SetValue(Result, TValue.From<TNotifyEvent>(DoChanged));
end;
end;
end;
if Assigned(OnCellCreated) then
OnCellCreated(Self, Result);
end;
procedure TGenericColumn<T>.DoChanged(Sender: TObject);
begin
DoTextChanged(Sender);
end;
end.
A Clickable HotLink/URLLabel for FireMonkey
Are you the kind of developer who likes to put a hotlink back to your website in the about box of your application? If so, you’ve probably noticed the lack of a clickable URL link component in FireMonkey.
Fortunately it isn’t difficult to create one. (Unless you want to do it in XE2, which has a number of gotchas and will be left for another day).
I could have done the visual stuff with a custom style but chose to make the changes in code in order to save the need to customise for every style which a developer may use, and also because some changes, such as the need to set HitTest, are easily missed.
Here’s the class declaration. We have an AutoOpen property which, if true, will assume the Text property is a URL and open it when clicked. Otherwise you can monitor the OnOpenURL event for clicks.
type TURLLabel = class(TLabel)
private
FAutoOpen: Boolean;
FOnOpenURL: TNotifyEvent;
protected
procedure ApplyStyle;override;
procedure EVTextClick(Sender: TObject);
public
constructor Create(AOwner: TComponent);override;
published
//If True, clicking opens a browser window on the contents of the Text property,
//if False, you'll need to monitor the OnOpenURL event
property AutoOpen: Boolean read FAutoOpen write FAutoOpen default True;
property OnOpenURL: TNotifyEvent read FOnOpenURL write FOnOpenURL;
end;
The Create constructor sets the appearance. Note how we have to set the StyledSettings property in order to override what comes from the style.
constructor TURLLabel.Create(AOwner: TComponent);
begin
inherited;
FAutoOpen := True;
FontColor := claBlue;
Font.Style := Font.Style+[TFontStyle.fsUnderline];
StyledSettings := StyledSettings-[TStyledSetting.ssFontColor, TStyledSetting.ssStyle];
end;
Now we have ApplyStyle which makes changes to the text of the label. Setting HitTest is vital, since otherwise mouse clicks will be ignored and the TText’s OnClick event handler will never fire.
procedure TURLLabel.ApplyStyle;
var O: TFMXObject;
T: TText;
begin
inherited;
O := FindStyleResource('text');
if O is TText then
begin
T := TText(O);
T.OnClick := EVTextClick;
T.HitTest := True;
T.Cursor := crHandPoint;
end;
end;
Finally we have the EVTextClick event handler which fires when the label’s TText (from the style) is clicked,
procedure TURLLabel.EVTextClick(Sender: TObject);
begin
if AutoOpen then
begin
{$IFDEF MSWINDOWS}
ShellExecute(0, 'OPEN', PChar(Text), '', '', SW_SHOWNORMAL);
{$ENDIF MSWINDOWS}
{$IFDEF POSIX}
_system(PAnsiChar('open ' + AnsiString(sCommand)));
{$ENDIF POSIX}
end;
if Assigned(OnOpenURL) then
OnOpenURL(Self);
end;
The Code
Full Source
unit URLLabelXE3;
interface
uses Classes, FMX.Types, FMX.Controls, FMX.Objects;
type TURLLabel = class(TLabel)
private
FAutoOpen: Boolean;
FOnOpenURL: TNotifyEvent;
protected
procedure ApplyStyle;override;
procedure EVTextClick(Sender: TObject);
public
constructor Create(AOwner: TComponent);override;
published
//If True, clicking opens a browser window on the contents of the Text property,
//if False, you'll need to monitor the OnOpenURL event
property AutoOpen: Boolean read FAutoOpen write FAutoOpen default True;
property OnOpenURL: TNotifyEvent read FOnOpenURL write FOnOpenURL;
end;
procedure Register;
implementation
uses System.UIConsts, System.UITypes,
{$IFDEF MSWINDOWS}
Winapi.ShellAPI, Winapi.Windows;
{$ENDIF MSWINDOWS}
{$IFDEF POSIX}
Posix.Stdlib;
{$ENDIF POSIX}
procedure Register;
begin
RegisterComponents('SolentFMX', [TURLLabel]);
end;
{ TURLLabel }
procedure TURLLabel.ApplyStyle;
var O: TFMXObject;
T: TText;
begin
inherited;
O := FindStyleResource('text');
if O is TText then
begin
T := TText(O);
T.OnClick := EVTextClick;
T.HitTest := True;
T.Cursor := crHandPoint;
end;
end;
constructor TURLLabel.Create(AOwner: TComponent);
begin
inherited;
FAutoOpen := True;
FontColor := claBlue;
Font.Style := Font.Style+[TFontStyle.fsUnderline];
StyledSettings := StyledSettings-[TStyledSetting.ssFontColor, TStyledSetting.ssStyle];
end;
procedure TURLLabel.EVTextClick(Sender: TObject);
begin
if AutoOpen then
begin
{$IFDEF MSWINDOWS}
ShellExecute(0, 'OPEN', PChar(Text), '', '', SW_SHOWNORMAL);
{$ENDIF MSWINDOWS}
{$IFDEF POSIX}
_system(PAnsiChar('open ' + AnsiString(sCommand)));
{$ENDIF POSIX}
end;
if Assigned(OnOpenURL) then
OnOpenURL(Self);
end;
initialization
RegisterFMXClasses([TURLLabel]);
end.
Adding Images to a FireMonkey TreeView
If you’re familiar with the TreeView in VCL you’ll probably know that it’s possible to add an image to each item, but that that behaviour isn’t supported out of the box in FireMonkey. So, lets add the support.
There are a number of ways this could be done, but the simplest is probably by adding a TImage to the style for TTreeViewItem. A TImage contains a TBitmap which has a StyleLookup property. This property is a string which takes the StyleName of another element style element - for another TImage. What we’ll do then is simply add any images to be used to the style, and point the TImage in the style of each TreeViewItem to the one we want to use.
The Style
Start by copying the style for a TTreeViewItem (TreeViewItemStyle) and call it TreeViewImageItemStyle. The TImage needs to go in the same TLayout as the checkbox, but we want to add it inside another TLayout - this means the item can be resized while we keep the TImage at the same size.
(To copy the style element in the IDE, double click on the TTreeView in the form designer and add an item. Back out, then right click on the item and select Edit Custom Style. Make the changes and click Apply and Close).
So, add the TLayout and set the properties, Align := alLeft and Width := 20.
And add the TImage under it and set the properties, StyleName := ‘image’, Align := alCentre, WrapMode := iwStretch, HitTest := False and Height and Width := 16.
The Class
Now we need to create a custom TreeViewItem class, which we’ll call TTreeViewImageItem (note our style is TreeViewImageItemStyle). Here’s our class definition:
type TTreeViewImageItem = class(TTreeViewItem)
private
FImage: TImage;
FShowImage: Boolean;
FImageStyleLookup: String;
procedure SetShowImage(const Value: Boolean);
procedure SetImageStyleLookup(const Value: String);
protected
procedure ApplyStyle;override;
procedure FreeStyle;override;
public
constructor Create(AOwner: TComponent);override;
published
property ImageStyleLookup: String read FImageStyleLookup write SetImageStyleLookup;
property ShowImage: Boolean read FShowImage write SetShowImage default True;
end;
The property ImageStyleLookup takes the name of the style element to show as an image.
ApplyStyle and FreeStyle are pretty standard, simply fetching or nilling FImage and passing across the ImageStyleLookup.
procedure TTreeViewImageItem.ApplyStyle;
var O: TFMXObject;
begin
inherited;
O := FindStyleResource('image');
if O is TImage then
begin
FImage := TImage(O);
FImage.Visible := ShowImage;
FImage.Bitmap.StyleLookup := FImageStyleLookup;
end;
end;
procedure TTreeViewImageItem.FreeStyle;
begin
inherited;
FImage := nil;
end;
Also simple are the two property setters,
procedure TTreeViewImageItem.SetImageStyleLookup(const Value: String);
var O: TFMXObject;
begin
FImageStyleLookup := Value;
if Assigned(FImage) then
FImage.Bitmap.StyleLookup := Value;
end;
procedure TTreeViewImageItem.SetShowImage(const Value: Boolean);
begin
FShowImage := Value;
if Assigned(FImage) then
FImage.Visible := Value;
end;
Sample Application
Now we simply need to create something to test it all. Start by adding two images to the style with StyleNames of Image1 and Image2. For my test I’ve use thumbs up and thumbs down graphics.
And our test project simply has a TTreeView and a button. The button adds a new item as the child of the selected item, and sets the image to thumbs up if the index of the item is positive and thumbs down if it is negative,
procedure TForm1.Button1Click(Sender: TObject);
var Item: TTreeViewImageItem;
begin
Item := TTreeViewImageItem.Create(Self);
inc(Index);
Item.Text := 'Item'+IntToStr(Index);
if (Index mod 2) = 1 then
Item.ImageStyleLookup := 'Image1'
else
Item.ImageStyleLookup := 'Image2';
if TreeView1.Selected <> nil then
begin
Item.Parent := TreeView1.Selected;
TreeView1.Selected.IsExpanded := True;
end
else
Item.Parent := TreeView1;
end;
Enjoy.
Full source:
unit TreeViewImage;
interface
uses FMX.TreeView, FMX.Objects, FMX.Types, Classes;
type TTreeViewImageItem = class(TTreeViewItem)
private
FImage: TImage;
FShowImage: Boolean;
FImageStyleLookup: String;
procedure SetShowImage(const Value: Boolean);
procedure SetImageStyleLookup(const Value: String);
protected
procedure ApplyStyle;override;
procedure FreeStyle;override;
public
constructor Create(AOwner: TComponent);override;
published
property ImageStyleLookup: String read FImageStyleLookup write SetImageStyleLookup;
property ShowImage: Boolean read FShowImage write SetShowImage default True;
end;
implementation
{ TTreeViewImageItem }
procedure TTreeViewImageItem.ApplyStyle;
var O: TFMXObject;
begin
inherited;
O := FindStyleResource('image');
if O is TImage then
begin
FImage := TImage(O);
FImage.Visible := ShowImage;
FImage.Bitmap.StyleLookup := FImageStyleLookup;
end;
end;
constructor TTreeViewImageItem.Create(AOwner: TComponent);
begin
inherited;
ShowImage := True;
end;
procedure TTreeViewImageItem.FreeStyle;
begin
inherited;
FImage := nil;
end;
procedure TTreeViewImageItem.SetImageStyleLookup(const Value: String);
var O: TFMXObject;
begin
FImageStyleLookup := Value;
if Assigned(FImage) then
FImage.Bitmap.StyleLookup := Value;
end;
procedure TTreeViewImageItem.SetShowImage(const Value: Boolean);
begin
FShowImage := Value;
if Assigned(FImage) then
FImage.Visible := Value;
end;
end.
How do you Change the Color of a Panel in FireMonkey?
The above is a question which comes up frequently from newbies to FireMonkey. It’s an important question, and answering it opens the door to learning a lot of the power of FireMonkey.
The Short Answer
The short answer is: In FireMonkey the appearance of a control comes from the style. So, to change the appearance you need to change the style.
The Long Answer
Let’s look at how to do that in detail. Fire up XE3, start a new project and add two TPanels to the form.
Right click on a panel and select Edit Default Style.
The Structure Pane shows the style for the panel, ‘panelstyle’. Select it to edit it.
Now make some edits, in my case I’ve changed the Fill.Kind property to bkGradient and the Stroke.Thickness and Stroke.Dash properties.
Click Apply and Close to return to the form.
Note that the IDE has made a few changes for you here, it has:
* Added a TStyleBook to the form (StyleBook1).
* Set the form’s StyleBook property to StyleBook1.
The StyleBook contains the styles which have been modified for this form. In this case we have modified the default style for a TPanel. In other words we have added a style for a panel to the stylebook and this has overridden the default style of the app (note how both panels have changed to the new style).
Custom Styles
But suppose you only want to change the style for just one or two panels instead of all of them. This time, right click on a panel an select Edit Custom Style.
Notice now that the IDE has created a custom style for us, panel1style1.
Let’s make some more changes and again click Apply and Close. I’ve now changed the gradient to some funky colors and set the Stroke.Kind to bkNone.
Look at the properties for the panel and you’ll note that the StyleLookup is set to Panel1Style1, the name of the custom style the IDE created for us.
Changing the StyleLookup property tells FireMonkey to look for a style other than the default one. Now set the StyleLookup for the other panel to Panel1Style1 and you’ll see both panels using the same custom style.
You can use the same process to create as many different panel styles as you want, or to change the styles for other classes of controls.
Note: If you’re using XE2, some of the property names of the TRectangle will be slightly different, but otherwise everything works the same.
MonkeyStyler Build 12: Component Palette
MonkeyStyler build 12 is now available. The main change is a new component palette, ver much like you’re used to in Delphi. Search (except in the XE2 edition), select and click on the components tree or control preview to add a new component. You can also use drag and drop.
Other improvements are drag and drop support in the components tree and a fix for a bug which caused errors at startup on computers where the regional settings for a decimal separator where not a period (.).
Full changelist
Added: Component palette with search and highlighting of search terms.
(Note search is unavailable in XE2 due to treeview issues.
Added: Select component on Palette and click on Component Tree of Viewer to add it.
Fixed: Editing StyleName property caused editor to lose focus.
Fixed: Work around for effects not updating in Control Viewer (QC 110506).
Added: Drag/drop support to the components tree.
Fixed: Errors at start up if decimal separator was a comma in users regional settings.
File Management in MonkeyStyler
A quick video of file management features in MonkeyStyler
Fixing Drag and Drop in a FireMonkey Tree View
I’ve been preparing to add some drag and drop support to MonkeyStyler, chiefly revolving around a couple of tree views. So, I set out to investigate drag/drop for a TTreeView. I figured the automatic drag/drop support wouldn’t be enough for me but I started with it to see how things worked, and what I’d need to adapt.
What I found wasn’t a pretty picture. The issues I found where:
* It takes two clicks to start a drag operation: one to select an item, another to pick it up ans start dragging QC 110783.
* You can’t drop onto another tree view if it the destination’s Selected = nil QC 110646.
* The built in code selects the wrong item when hovering or dropping unless the tree view’s Position is at (0,0) on the form QC 110721.
all of which make the built in support unusable.
And finally comes the enhancements I need to use for MonkeyStyler:
* The built in behaviour is to move a TTreeViewItem from one location to another but I also need to be able to manage the data structures behind the tree view.
* I want the ability to copy an item (and related back end data).
* I want to be able to move items other than TTreeViewItems (at present that means dragging an class from a palette and creating an instance of that class on dropping).
So I set about fixing the broken stuff and adding support for what I neeed.
The code attached to this post is a child component of TTreeView which reworks the default drag/drop behaviour to fix the issues above. Much of it is simply a cut/paste of the existing code with bug fixes added plus some rather nasty hacks to remove default behaviour and access a private field which is needed.
Behaviour of the new code is:
* Added an EnableDrag property which replaces the AllowDrag property. Set EnableDrag to True to switch on the dragging behaviour. Do not set both EnableDrag and AllowDrag to true. Indeed, don’t use AllowDrag at all, that will simply return you to the old two-clicks to drag behaviour.
* Added an OnDropItem event. If this is assigned then the event handler is solely responsible for handling any reparenting or other processing necessary when an item is dropped. The minimal code necessary to move an item would be (ignoring sanity checks):
TFMXObject(Item).Parent := TFMXObject(NewParent);
You can, of course, process the new item in any way you see fit.
The code at present is XE3 only. As and when I add XE2 support I’ll update the code and this post. The download includes a sample project with three tree views you can drag between. Uncomment the line to add an OnDropItem event handler to test that functionality.
Update 27/11/12 to fix OnChange event not firing.
Full source:
unit Solent.TreeView;
interface
uses FMX.TreeView, System.UITypes, System.Classes, FMX.Types, SYstem.Types;
type TDropItemEvent = procedure(Sender, NewParent, Item: TObject) of object;
type TSolentTreeView = class(TTreeView)
private
FEnableDrag: Boolean;
FOnDropItem: TDropItemEvent;
function GetDragItem: TTreeViewItem;
procedure SetDragItem(const Value: TTreeViewItem);
protected
MouseDownPoint: TPointF;
DragStartItem: TTreeViewItem;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);override;
procedure MouseMove(Shift: TShiftState; X, Y: Single);override;
procedure DoMouseLeave;override;
procedure DragOver(const Data: TDragObject; const Point: TPointF;var Accept: Boolean);override;
procedure DragDrop(const Data: TDragObject; const Point: TPointF);override;
procedure StartDrag;virtual;
//Hack: Use RTTI to get acces to the private FDragItem field
property DragItem: TTreeViewItem read GetDragItem write SetDragItem;
public
published
//Use EnableDrag instead of AllowDrag. Setting both to true will not be good.
property EnableDrag: Boolean read FEnableDrag write FEnableDrag;
//If OnDropItem is assigned, then no automatic reparenting will happen.
//It is entirely up to the handler to add/reparent/delete as necessary.
//(Note that a default drag/drop would simply by: TFMXObject(Item).Parent := TFMXObject(NewParent);
property OnDropItem: TDropItemEvent read FOnDropItem write FOnDropItem;
end;
procedure Register;
implementation
uses FMX.Platform, System.RTTI, FMX.Forms, FMX.Layouts;
const DragDelta = 5; //No of pixels to move the mouse before starting a drag operation
procedure Register;
begin
RegisterComponents('Solent', [TSolentTreeView]);
end;
{ TSolentTreeView }
type
THackControl = class(TControl);
TDragOver = procedure(const Data: TDragObject;const Point: TPointF; var Accept: Boolean) of object;
TDragDrop = procedure(const Data: TDragObject;const Point: TPointF) of object;
procedure TSolentTreeView.StartDrag;
var Data: TDragObject;
Bitmap: TBitmap;
P: TFMXObject;
DragDrop: IInterface;
begin
if EnableDrag and Assigned(DragStartItem) then
begin
DragDrop := TPlatformServices.Current.GetPlatformService(IFMXDragDropService);
if Assigned(DragDrop) then
begin
Data.Source := DragStartItem;
Data.Data := TValue.From<TObject>(Self);
P := Parent;
while Assigned(P) and not (P is TCommonCustomForm) do
P := P.Parent;
if Assigned(P) then
try
Bitmap := DragStartItem.MakeScreenShot;
IFMXDragDropService(DragDrop).BeginDragDrop(TCommonCustomForm(P), Data, Bitmap);
finally
Bitmap.Free;
end;
end;
DragStartItem := nil;
end;
end;
procedure TSolentTreeView.DoMouseLeave;
begin
inherited;
StartDrag;
end;
procedure TSolentTreeView.DragDrop(const Data: TDragObject;
const Point: TPointF);
var
Item: TTreeViewItem;
Allow: Boolean;
P: TPointF;
Proc: TDragDrop;
begin
//Inherited method from TCustomTreeView is broken.
//Parent of TCustomTreeView is TScrollBox.
//Hack our way over the inherited method to get to the one in TScrollBox
//Credit to Serg http://stackoverflow.com/users/246408/serg
TMethod(Proc).Code := @TScrollBox.DragDrop;
TMethod(Proc).Data := Self;
Proc(Data, Point);
if Assigned(DragItem) then
begin
THackControl(DragItem).DragLeave;
DragItem.RemoveFreeNotify(Self);
DragItem := nil;
end;
Item := ItemByPoint(Point.X, Point.Y);
if Not Assigned(Item) then
begin
// to root
Allow := True;
if Assigned(OnDragChange) then
OnDragChange(TTreeViewItem(Data.Source), nil, Allow);
if Allow then
begin
if Assigned(OnDropItem) then
OnDropItem(Self, Self, Data.Source)
else
TTreeViewItem(Data.Source).Parent := Self;
Realign;
end;
end
else
begin
Allow := True;
if Assigned(OnDragChange) then
OnDragChange(TTreeViewItem(Data.Source), Item, Allow);
if Allow then
begin
if not TTreeViewItem(Data.Source).isChild(Item) then
begin
if not Item.IsExpanded then
Item.IsExpanded := True;
if Assigned(OnDropItem) then
OnDropItem(Self, Item, Data.Source)
else
TTreeViewItem(Data.Source).Parent := Item;
Realign;
end;
end;
end;
end;
procedure TSolentTreeView.DragOver(const Data: TDragObject;
const Point: TPointF; var Accept: Boolean);
var Item: TTreeViewItem;
Proc: TDragOver;
begin
//Inherited method from TCustomTreeView is broken.
//Parent of TCustomTreeView is TScrollBox.
//Hack our way over the inherited method to get to the one in TScrollBox
//Credit to Serg http://stackoverflow.com/users/246408/serg
TMethod(Proc).Code := @TScrollBox.DragOver;
TMethod(Proc).Data := Self;
Proc(Data, Point, Accept);
Item := ItemByPoint(Point.X, Point.Y);
if (Item <> DragItem) then
begin
if Assigned(DragItem) then
begin
THackControl(DragItem).DragLeave;
DragItem.RemoveFreeNotify(Self);
end;
DragItem := Item;
if Assigned(DragItem) then
begin
DragItem.AddFreeNotify(Self);
THackControl(DragItem).DragEnter(Data, Point);
Accept := True;
end
else
Accept := False;
end
else
Accept := True;
if (DragItem <> nil) and (DragItem = Selected) then
Accept := False;
end;
function TSolentTreeView.GetDragItem: TTreeViewItem;
var C: TRTTIContext;
T: TRTTIType;
F: TRTTIField;
V: TValue;
begin
Result := nil;
C := TRTTIContext.Create;
T := C.GetType(ClassInfo);
if T <> nil then
begin
F := T.GetField('FDragItem');
if F <> nil then
begin
V := F.GetValue(Self);
Result := V.AsType<TTreeViewItem>;
end;
end;
C.Free;
end;
procedure TSolentTreeView.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Single);
var Item: TTreeViewItem;
begin
inherited;
if EnableDrag then
begin
DragStartItem := ItemByPoint(X, Y);
MouseDownPoint.X := X;
MouseDownPoint.Y := Y;
end
else
DragStartItem := nil;
end;
procedure TSolentTreeView.MouseMove(Shift: TShiftState; X, Y: Single);
begin
inherited;
if (abs(X-MouseDownPoint.X) > DragDelta) or (abs(Y-MouseDownPoint.Y) > DragDelta) then
StartDrag;
end;
procedure TSolentTreeView.SetDragItem(const Value: TTreeViewItem);
var C: TRTTIContext;
T: TRTTIType;
F: TRTTIField;
V: TValue;
begin
C := TRTTIContext.Create;
T := C.GetType(ClassInfo);
if T <> nil then
begin
F := T.GetField('FDragItem');
if F <> nil then
F.SetValue(Self, TValue.From<TTreeViewItem>(Value));
end;
C.Free;
end;
initialization
RegisterFMXClasses([TSolentTreeView]);
end.
