Category: Coding

Articles about coding for FireMonkey

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.TreeViewClasses;

type TTreeViewItemExpanded = class(TTreeViewItem)
  private
    
FOnChangeExpandedTNotifyEvent;
  protected
    
procedure ApplyStyle;override;
    
procedure DoChangeExpanded(SenderTObject);
  
published
    property OnChangeExpanded
TNotifyEvent read FOnChangeExpanded write FOnChangeExpanded;
end;

implementation
uses FMX
.AniFMX.Types;

{ TTreeViewItemExpanded }

procedure TTreeViewItemExpanded
.ApplyStyle;
var 
AniTFloatAnimation;
  
OTFMXObject;
begin
  inherited
;

  
:= FindStyleResource('button');
  if 
Assigned(Othen
  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(SenderTObject);
begin
  
if Assigned(OnChangeExpandedthen
    OnChangeExpanded
(Self);
end;

end

And here’s a bit of code from the app to test things out,

procedure TForm1.EVChangeExpanded(SenderTObject);
var 
ItemTTreeViewItem;
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(SenderTObject);
var 
ItemTTreeViewItemExpanded;
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

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<TTStyledControl> = class(TColumn)
  private
    
FOnCellCreatedTCellCreatedEvent;
  protected
    function 
CreateCellControlTStyledControl;override;
  public
    
procedure DoChanged(SenderTObject);
  
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>.CreateCellControlTStyledControl;
begin
  Result 
:= TStyledControlClass(T).Create(Self);
  if 
Assigned(OnCellCreatedthen
    OnCellCreated
(SelfResult);
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(SenderTObject);
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(SenderTObject);
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(SenderTObject; var CellTStyledControl);
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>.CreateCellControlTStyledControl;
var
  
CTRTTIContext;
  
RTTRTTIType;
  
PTRTTIProperty;
  
PTTRTTIType;
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.

:= TRTTIContext.Create

We get a TRTTIType for our class

RT := C.GetType(Result.ClassInfo);
  if 
RT <> nil then
  begin 


We find the OnChange property.

:= RT.GetProperty('OnChange');
    if 
<> 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(ResultTValue.From<TNotifyEvent>(DoChanged));
      
end;
    
end;
  
end;

  if 
Assigned(OnCellCreatedthen
    OnCellCreated
(SelfResult);
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.GridFMX.Types;

type TStyledControlClass = class of TStyledControl;

type TCellCreatedEvent procedure(SenderTObject;var Cell:TStyledControlof object;

type TGenericColumn<TTStyledControl> = class(TColumn)
  private
    
FOnCellCreatedTCellCreatedEvent;
  protected
    function 
CreateCellControlTStyledControl;override;
  public
    
procedure DoChanged(SenderTObject);
  
published
    property OnCellCreated
TCellCreatedEvent read FOnCellCreated write FOnCellCreated;
  
end;

implementation
uses RTTI
Classes;

{ TGenericColumn<T}

function TGenericColumn<T>.CreateCellControlTStyledControl;
var
  
CTRTTIContext;
  
RTTRTTIType;
  
PTRTTIProperty;
  
PTTRTTIType;
begin
  Result 
:= TStyledControlClass(T).Create(Self);

  
:= TRTTIContext.Create;
  
RT := C.GetType(Result.ClassInfo);
  if 
RT <> nil then
  begin
    P 
:= RT.GetProperty('OnChange');
    if 
<> nil then
    begin
      
if P.PropertyType.QualifiedName 'System.Classes.TNotifyEvent' then
      begin
        P
.SetValue(ResultTValue.From<TNotifyEvent>(DoChanged));
      
end;
    
end;
  
end;

  if 
Assigned(OnCellCreatedthen
    OnCellCreated
(SelfResult);
end;

procedure TGenericColumn<T>.DoChanged(SenderTObject);
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
    
FAutoOpenBoolean;
    
FOnOpenURLTNotifyEvent;
  protected
    
procedure ApplyStyle;override;
    
procedure EVTextClick(SenderTObject);
  public
    
constructor Create(AOwnerTComponent);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 AutoOpenBoolean read FAutoOpen write FAutoOpen default True;
    
property OnOpenURLTNotifyEvent 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(AOwnerTComponent);
begin
  inherited
;
  
FAutoOpen := True;

  
FontColor := claBlue;
  
Font.Style := Font.Style+[TFontStyle.fsUnderline];
  
StyledSettings := StyledSettings-[TStyledSetting.ssFontColorTStyledSetting.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 
OTFMXObject;
  
TTText;
begin
  inherited
;
  
:= 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(SenderTObject);
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(OnOpenURLthen
    OnOpenURL
(Self);
end

The Code

Download Sample Project

Full Source

unit URLLabelXE3;

interface
uses ClassesFMX.TypesFMX.ControlsFMX.Objects;

type TURLLabel = class(TLabel)
  private
    
FAutoOpenBoolean;
    
FOnOpenURLTNotifyEvent;
  protected
    
procedure ApplyStyle;override;
    
procedure EVTextClick(SenderTObject);
  public
    
constructor Create(AOwnerTComponent);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 AutoOpenBoolean read FAutoOpen write FAutoOpen default True;
    
property OnOpenURLTNotifyEvent read FOnOpenURL write FOnOpenURL;
  
end;

procedure Register;

implementation
uses System
.UIConstsSystem.UITypes,
{$IFDEF MSWINDOWS}
  Winapi
.ShellAPIWinapi.Windows;
{$ENDIF MSWINDOWS}
{$IFDEF POSIX}
  Posix
.Stdlib;
{$ENDIF POSIX}

procedure Register
;
begin
  RegisterComponents
('SolentFMX'[TURLLabel]);
end;

{ TURLLabel }

procedure TURLLabel
.ApplyStyle;
var 
OTFMXObject;
  
TTText;
begin
  inherited
;
  
:= 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(AOwnerTComponent);
begin
  inherited
;
  
FAutoOpen := True;

  
FontColor := claBlue;
  
Font.Style := Font.Style+[TFontStyle.fsUnderline];
  
StyledSettings := StyledSettings-[TStyledSetting.ssFontColorTStyledSetting.ssStyle];
end;

procedure TURLLabel.EVTextClick(SenderTObject);
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(OnOpenURLthen
    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
    
FImageTImage;
    
FShowImageBoolean;
    
FImageStyleLookupString;
    
procedure SetShowImage(const ValueBoolean);
    
procedure SetImageStyleLookup(const ValueString);
  protected
    
procedure ApplyStyle;override;
    
procedure FreeStyle;override;
  public
    
constructor Create(AOwnerTComponent);override;
  
published
    property ImageStyleLookup
String read FImageStyleLookup write SetImageStyleLookup;
    
property ShowImageBoolean 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 
OTFMXObject;
begin
  inherited
;

  
:= 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 ValueString);
var 
OTFMXObject;
begin
  FImageStyleLookup 
:= Value;
  if 
Assigned(FImagethen
    FImage
.Bitmap.StyleLookup := Value;
end;

procedure TTreeViewImageItem.SetShowImage(const ValueBoolean);
begin
  FShowImage 
:= Value;
  if 
Assigned(FImagethen
    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(SenderTObject);
var 
ItemTTreeViewImageItem;
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

Download Project ZIP file

Enjoy.

Full source:

unit TreeViewImage;

interface
uses FMX.TreeViewFMX.ObjectsFMX.TypesClasses;

type TTreeViewImageItem = class(TTreeViewItem)
  private
    
FImageTImage;
    
FShowImageBoolean;
    
FImageStyleLookupString;
    
procedure SetShowImage(const ValueBoolean);
    
procedure SetImageStyleLookup(const ValueString);
  protected
    
procedure ApplyStyle;override;
    
procedure FreeStyle;override;
  public
    
constructor Create(AOwnerTComponent);override;
  
published
    property ImageStyleLookup
String read FImageStyleLookup write SetImageStyleLookup;
    
property ShowImageBoolean read FShowImage write SetShowImage default True;
  
end;

implementation

{ TTreeViewImageItem }

procedure TTreeViewImageItem
.ApplyStyle;
var 
OTFMXObject;
begin
  inherited
;

  
:= FindStyleResource('image');
  if 
O is TImage then
  begin
    FImage 
:= TImage(O);
    
FImage.Visible := ShowImage;
    
FImage.Bitmap.StyleLookup := FImageStyleLookup;
  
end;
end;

constructor TTreeViewImageItem.Create(AOwnerTComponent);
begin
  inherited
;
  
ShowImage := True;
end;

procedure TTreeViewImageItem.FreeStyle;
begin
  inherited
;
  
FImage := nil;
end;

procedure TTreeViewImageItem.SetImageStyleLookup(const ValueString);
var 
OTFMXObject;
begin
  FImageStyleLookup 
:= Value;
  if 
Assigned(FImagethen
    FImage
.Bitmap.StyleLookup := Value;
end;

procedure TTreeViewImageItem.SetShowImage(const ValueBoolean);
begin
  FShowImage 
:= Value;
  if 
Assigned(FImagethen
    FImage
.Visible := Value;
end;

end

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.TreeViewSystem.UITypesSystem.ClassesFMX.TypesSYstem.Types;

type TDropItemEvent procedure(SenderNewParentItemTObjectof object;

type TSolentTreeView = class(TTreeView)
  private
    
FEnableDragBoolean;
    
FOnDropItemTDropItemEvent;
    function 
GetDragItemTTreeViewItem;
    
procedure SetDragItem(const ValueTTreeViewItem);
  protected
    
MouseDownPointTPointF;
    
DragStartItemTTreeViewItem;
    
procedure MouseDown(ButtonTMouseButtonShiftTShiftStateXYSingle);override;
    
procedure MouseMove(ShiftTShiftStateXYSingle);override;
    
procedure DoMouseLeave;override;
    
procedure DragOver(const DataTDragObject; const PointTPointF;var AcceptBoolean);override;
    
procedure DragDrop(const DataTDragObject; const PointTPointF);override;
    
procedure StartDrag;virtual;
    
//Hack: Use RTTI to get acces to the private FDragItem field
    
property DragItemTTreeViewItem read GetDragItem write SetDragItem;
  public
  
published
    
//Use EnableDrag instead of AllowDrag. Setting both to true will not be good.
    
property EnableDragBoolean 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 OnDropItemTDropItemEvent read FOnDropItem write FOnDropItem;
  
end;

procedure Register;

implementation
uses FMX
.PlatformSystem.RTTIFMX.FormsFMX.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 DataTDragObject;const PointTPointF; var AcceptBooleanof object;
  
TDragDrop procedure(const DataTDragObject;const PointTPointFof object;

procedure TSolentTreeView.StartDrag;
var 
DataTDragObject;
  
BitmapTBitmap;
  
PTFMXObject;
  
DragDropIInterface;
begin
  
if EnableDrag and Assigned(DragStartItemthen
  begin
    DragDrop 
:= TPlatformServices.Current.GetPlatformService(IFMXDragDropService);
    if 
Assigned(DragDropthen
    begin
      Data
.Source := DragStartItem;
      
Data.Data := TValue.From<TObject>(Self);
      
:= Parent;
      while 
Assigned(P) and not (P is TCommonCustomForm) do
        
:= P.Parent;
      if 
Assigned(Pthen
      
try
        
Bitmap := DragStartItem.MakeScreenShot;
        
IFMXDragDropService(DragDrop).BeginDragDrop(TCommonCustomForm(P), DataBitmap);
      finally
        
Bitmap.Free;
      
end;
    
end;
    
DragStartItem := nil;
  
end;
end;

procedure TSolentTreeView.DoMouseLeave;
begin
  inherited
;
  
StartDrag;
end;

procedure TSolentTreeView.DragDrop(const DataTDragObject;
  const 
PointTPointF);
  var
  
ItemTTreeViewItem;
  
AllowBoolean;
  
PTPointF;
  
ProcTDragDrop;
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(DataPoint);

  if 
Assigned(DragItemthen
  begin
    THackControl
(DragItem).DragLeave;
    
DragItem.RemoveFreeNotify(Self);
    
DragItem := nil;
  
end;
  
Item := ItemByPoint(Point.XPoint.Y);
  if 
Not Assigned(Itemthen
  begin
    
// to root
    
Allow := True;
    if 
Assigned(OnDragChangethen
      OnDragChange
(TTreeViewItem(Data.Source), nilAllow);
    if 
Allow then
    begin
      
if Assigned(OnDropItemthen
        OnDropItem
(SelfSelfData.Source)
      else
        
TTreeViewItem(Data.Source).Parent := Self;
      
Realign;
    
end;
  
end
  
else
  
begin
    Allow 
:= True;
    if 
Assigned(OnDragChangethen
      OnDragChange
(TTreeViewItem(Data.Source), ItemAllow);
    if 
Allow then
    begin
      
if not TTreeViewItem(Data.Source).isChild(Itemthen
      begin
        
if not Item.IsExpanded then
          Item
.IsExpanded := True;
        if 
Assigned(OnDropItemthen
          OnDropItem
(SelfItemData.Source)
        else
          
TTreeViewItem(Data.Source).Parent := Item;
        
Realign;
      
end;
    
end;
  
end;
end;

procedure TSolentTreeView.DragOver(const DataTDragObject;
  const 
PointTPointF; var AcceptBoolean);
var 
ItemTTreeViewItem;
  
ProcTDragOver;
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(DataPointAccept);

  
Item := ItemByPoint(Point.XPoint.Y);
  if (
Item <> DragItemthen
  begin
    
if Assigned(DragItemthen
    begin
      THackControl
(DragItem).DragLeave;
      
DragItem.RemoveFreeNotify(Self);
    
end;
    
DragItem := Item;
    if 
Assigned(DragItemthen
    begin
      DragItem
.AddFreeNotify(Self);
      
THackControl(DragItem).DragEnter(DataPoint);
      
Accept := True;
    
end
    
else
      
Accept := False;
  
end
  
else
    
Accept := True;

  if (
DragItem <> nil) and (DragItem Selectedthen
    Accept 
:= False;
end;

function 
TSolentTreeView.GetDragItemTTreeViewItem;
var 
CTRTTIContext;
  
TTRTTIType;
  
FTRTTIField;
  
VTValue;
begin
  Result 
:= nil;
  
:= TRTTIContext.Create;
  
:= C.GetType(ClassInfo);
  if 
<> nil then
  begin
    F 
:= T.GetField('FDragItem');
    if 
<> nil then
    begin
      V 
:= F.GetValue(Self);
      
Result := V.AsType<TTreeViewItem>;
    
end;
  
end;
  
C.Free;
end;

procedure TSolentTreeView.MouseDown(ButtonTMouseButtonShiftTShiftStateX,
  
YSingle);
var 
ItemTTreeViewItem;
begin
  inherited
;
  if 
EnableDrag then
  begin
    DragStartItem 
:= ItemByPoint(XY);
    
MouseDownPoint.:= X;
    
MouseDownPoint.:= Y;
  
end
  
else
    
DragStartItem := nil;
end;

procedure TSolentTreeView.MouseMove(ShiftTShiftStateXYSingle);
begin
  inherited
;
  if (
abs(X-MouseDownPoint.X) > DragDelta) or (abs(Y-MouseDownPoint.Y) > DragDeltathen
    StartDrag
;
end;

procedure TSolentTreeView.SetDragItem(const ValueTTreeViewItem);
var 
CTRTTIContext;
  
TTRTTIType;
  
FTRTTIField;
  
VTValue;
begin
  C 
:= TRTTIContext.Create;
  
:= C.GetType(ClassInfo);
  if 
<> nil then
  begin
    F 
:= T.GetField('FDragItem');
    if 
<> nil then
      F
.SetValue(SelfTValue.From<TTreeViewItem>(Value));
  
end;
  
C.Free;
end;

initialization
  RegisterFMXClasses
([TSolentTreeView]);
end

 

Resizing a FireMonkey Combo Box to Fit it’s Contents

MonkeyStyler displays two combo boxes on it’s toolbar, one to list the currently opened files and a second to list the elements in the current file. A number of users mentioned that long items in the combo box would be cropped and sometimes difficult to identify.

Creating a routine to resize a combo box made an interesting little challenge. We need to find the length of the longest item, but this needs to take account of the current font settings, and there’s no convenient ‘TextWidth’ function in FireMonkey. But we cab do it using a TText object.

I started by creating a TText object with AutoSize set to True and WordWrap set to False.

:= TText.Create(nil);
    
T.AutoSize := True;
    
T.WordWrap := False


Next we need to get the font used. In FireMonkey a TComboBox owns a TListBox which is used for the dropdown and the combo box copies the contents of the selected item into itself. So we really need the font of a TListBoxItem. I chose to use the font assigned to an actual list box item of the component:

if Items.Count 0 then
    begin
      Item 
:= ListBox.ListItems[0];
      
Item.ApplyStyleLookup;
      
:= Item.FindStyleResource('text');
      if 
O is TText then
        T
.Font.Assign(TText(O).Font);
            ... 


Note the call to ApplyStyleLookup which we need in case the item doesn’t currently have it’s styling applied. This could be because it is newly created or the styling has been removed - in FM2 the stying of non-visible controls is removed to save resources.

Next up is to iterate over the strings in Items and get the width of the widest,

for S in Items do
      
begin
        T
.Text := S;
        
//Bug in XE3: Assigning Text doesn't resize a TText, so hack around it.
        
T.AutoSize := False;
        
T.AutoSize := True;
        if 
<> nil then
          NewWidth 
:= T.Width+TControl(O).Padding.Left+TControl(O).Padding.Right;
        if 
NewWidth MinWidth then
          MinWidth 
:= NewWidth;
      
end


In the initial release of XE3 there is a bug in TText such that it doesn’t resize when you set the Text property, so we do a little dance with AutoSize to force an update. Also note we’re taking account of the Padding of the ‘text’ resource.

And finally we need to assign the new width, but since there is other stuff in the style besides the text we don’t know exactly what that is (especially if the style later changes). So, we calculate the width of the extra stuff with the current settings (Width-TControl(O).Width) and add out new width for the text,

:= FindStyleResource('content');
    if 
O is TControl then
      Width 
:= Width-TControl(O).Width+MinWidth

Putting it together, here is the complete code:

type TSolentComboBox = class(TComboBox)
  public
    
procedure ResizeToContents(MinWidthSingle);
  
end;
    
...

procedure TSolentComboBox.ResizeToContents(MinWidthSingle);
var
  
TTText;
  
NewWidthSingle;
  
OTFMXObject;
  
SString;
  
ItemTListBoxItem;
begin
  
try
    
:= TText.Create(nil);
    
T.AutoSize := True;
    
T.WordWrap := False;
    
:= nil;
    if 
Items.Count 0 then
    begin
      Item 
:= ListBox.ListItems[0];
      
Item.ApplyStyleLookup;
      
:= Item.FindStyleResource('text');
      if 
O is TText then
        T
.Font.Assign(TText(O).Font);
      
NewWidth := 0;
      for 
S in Items do
      
begin
        T
.Text := S;
        
//Bug in XE3: Assigning Text doesn't resize a TText, so hack around it.
        
T.AutoSize := False;
        
T.AutoSize := True;
        if 
<> nil then
          NewWidth 
:= T.Width+TControl(O).Padding.Left+TControl(O).Padding.Right;
        if 
NewWidth MinWidth then
          MinWidth 
:= NewWidth;
      
end;
    
end;

    
:= FindStyleResource('content');
    if 
O is TControl then
      Width 
:= Width-TControl(O).Width+MinWidth;

  finally
    
T.Free;
  
end;
end

ApplyStyle and FreeStyle in FireMonkey

If you’re writing custom controls for FireMonkey you’re probably overriding ApplyStyle with something like this:

procedure TWidget.ApplyStyle;
var 
TTFMXObject;
begin
    inherited
;
    
:= FindStyleResource('text');
    if 
T is TText then
        FText 
:= TText(T);
end

And so you should be. That’s entirely correct practice. You look for a component of the style and cache it for later re-use within your component.

procedure TWidget.SetText(const ValueString);
begin
    
if FText <> nil then
        FText
.Text := Value;
end

But as I was updating MonkeyStyler to run under XE3/FM2 I was getting some really obscure errors from my custom grid cells. The cached components would occasionally be junk, as though they had been free-ed behind my back. The errors always occured in the final cell in a row and I at first assumed there was some really odd off by one bug in FM2.

After much investigation I noticed that ApplyStyle was being called on cells which had long been created. But why would ApplyStyle be called more than once on a component?

It turns out that FM2 is being more conservative with resources and freeing style objects which are no longer needed to save memory. If a component disappears from view the library will call TStyleControl.Disappear which in turn calls the virtual TStyleControl.FreeStyle. I’ll admit I had’t even noticed these methods before.

The correct behaviour for any component which caches style resources in it’s ApplyStyle method is, therefore, to override FreeStyle and release them:

procedure TWidget.FreeStyle;
begin
    inherited
;
    
FText := nil;
end

Once I added that to MonkeyStyler’s custom cells all ran smoothly again.

Enjoy.

An XE2/FireMonkey Showcase

It’s now almost exactly twelve months since XE2 was released and with XE3 just around the corner it seems like a good time to look back on what people have achieved with the first generation of FireMonkey. Here are a selection of videos from around the internet mostly of commercial products developed in FireMonkey.

If you are developing something yourself or know of a product or demonstration I have missed please let me know. If there’s an interesting video available I’ll add it to a future post.

Crossroad task manager
A task manager, shown here running on a Mac. Sadly I can’t find a link to any kind of product page.

An SVG demo
A demonstration of the TSVG component from Apesuite for adding more advanced vector graphics than the built in TPath can manage. No video for this one, but you can follow the link to download the executable.

Exosphere
A pre-alpha version of an innovative piece of animation software with live editing of the animations. This was inspired by the classic video by Bret Victor (at about 30 minutes in) (BTW if you’re a programmer and you haven’t watched that video all the way through, you really need to).

The author writes that it only took about seven hours work to get to this stage, with most of that time spent on data formats etc. Again no link to a product page.

Multitrack Studio
This is music sequencing software which the author(s) converted to run on the Mac using FireMonkey. The video is a demonstration of the Mac OS X version. Product page

 

Erply
A retail POS system written in FireMonkey. Sadly the video doesn’t showcase FireMonkey as much as I’d like. Product page

 

2RemindMe
I’m not sure if this is a separate product or just a rebranding of Crossroads described above. Either way, here it is being demonstrated on an iPad. [url=http://2complicated.com/2remindme/]Product page

 

TuneMyApps
From the same author as 2RemindMe, this is an iPad app for analysing iTunes sales info. Product page

 

Video for TListBox with in place edit

I just added a video for my recent post about a list box with in place editing.