Sorting and Filtering List Boxes in FireMonkey

(This article applies to Delphi XE7. XE6 works in a similar way except that sorting and filtering cannot be used at the same time. The functionality is also available in XE5 but is somewhat buggy).

A little known feature of TListBox in FireMonkey is the ability to sort and/or filter the items in the list. This feature makes it really easy to implement incremental search in a FireMonkey app, or to sort by different columns of a custom list box item.

Sorting

Sorting is achieved by calling the Sort method and passing in a suitable comparison function. The function passed in can either be a straight function, the method of a class or an anonymous method. Sort expects the function to be of type TFmxObjectSortCompare, which is to say it needs to fit the parameter template:

function (LeftRightTFMXObject): Integer

Left and Right will be two list box items from your list. You will need to cast them to TListBoxItem, or whatever custom class you are using in your list box. The return value should be

<= -1 if Right should come after Left, 0 if both are equal or >

= 1 if Left should come after Right. You can, of course, choose any property of your list box items on which to sort.

In my example project I have created a simple file list box with a custom list box item which shows the file name and size:

type TFileListBoxItem = class(TListBoxItem)
  private
    
FFileSizeLongint;
    
procedure SetFileSize(const ValueLongint);
  
published
    property FileSize
Longint read FFileSize write SetFileSize;
end

The app has the option to sort on either the file name (ASCII) or the file size. My sorting functions are:

function TForm1.SortASCII(LeftRightTFMXObject): Integer;
begin
  Result 
:= CompareText((Left as TListBoxItem).Text, (Right as TListBoxItem).Text);
end;

function 
TForm1.SortNumeric(LeftRightTFMXObject): Integer;
begin
  Result 
:= (Left as TFileListBoxItem).FileSize - (Right as TFileListBoxItem).FileSize;
end

I can then set the sort order with:

procedure TForm1.SortChange(SenderTObject);
begin
  
if ASCII.IsChecked then
    SortFunc 
:= SortASCII
  
else
    
SortFunc := SortNumeric;
  
ListBox1.Sort(SortFunc);
//  ListBox1.RealignContent;    //Needed for XE6
end

You’ll notice here that I’m storing the sort function in the SortFunc property. This is because the sort function is not retained by the list box and we will need to repeat the call to Sort every time we modify the items in the list box. In this case that means when the user opens another folder for browsing.

Also notice that under XE6 you’ll need to call RealignContent on the list box to get the display updated but this issue has been fixed for XE7.

Filtering

Filtering is achieved by setting a suitable predicate function into the FilterPredicate property. This time you need a function which takes a string parameter and returns a boolean. The return value should be true if the item is to be shown and false otherwise.

As with the sort function we can use a straight function, a method of a class or an anonymous method. I’ve chosen to use an anonymous method for the example:

procedure TForm1.UseFilterChange(SenderTObject);
begin
  
//AV setting FilterPredicate on an empty list in XE7.
  
if ListBox1.Count 0 then
    
EXIT;
  if 
UseFilter.IsChecked then
  begin
    ListBox1
.FilterPredicate :=
      function(
SString): Boolean
      begin
        
if Filter.Text '' then
          Result 
:= True
        
else
          
Result := AnsiContainsText(SFilter.Text);
      
end;
  
end
  
else
    
ListBox1.FilterPredicate := nil;
end

You’ll note that I’m aborting the UseFilterChange method if the list box is empty. There’s currently a bug in XE7 which causes an exception if you set FilterPredicate when the list box is empty. This bug wasn’t present on XE6.


As you’ll remember we had to reapply the sorting when we updated the list. The FilterPredicate, however, is remembered by the list box and, under XE7 new items will be automatically filtered.

However, while the filter is remembered by the list box in our example the user can change the filter string at any time. Since I want the list to be filtered live while the user types into the filter edit box I need to let the list box know that the filter condition has changed. To do this I listen to the OnChangeTracking method of the Filter edit box and update the FilterPredicate property:

procedure TForm1.FilterChangeTracking(SenderTObject);
begin
  
if ListBox1.Count 0 then //This line needed for XE7
    
ListBox1.FilterPredicate := ListBox1.FilterPredicate;
end

Note again the test for an empty list needed under XE7 but not XE6.

Sorting and Filtering

Now you may want to be able to use both sorting and filtering at the same time. The first thing to say about this is that, under XE6, there are some nasty bugs which stop you using both together with no known work around.

If you’re using XE7 then you can, but with one caveat: while you can filter a sorted list, you can’t sort a filtered list. However this is easily worked around, simply remove the filter, sort and reapply the filter. Or even, sort, then remove and reapply the filter. My tests show this works well, with no nasty display glitches, although it does take a few moments.

In the example I start by updating the UseFilterChange method to remove the filter first (which also means I don’t need the else condition to clear the filter):

procedure TForm1.UseFilterChange(SenderTObject);
begin
  
//AV setting FilterPredicate on an empty list in XE7.
  
if ListBox1.Count 0 then
    
EXIT;
  
ListBox1.FilterPredicate := nil;  //<-- This line added
  
if UseFilter.IsChecked then
  begin
    ListBox1
.FilterPredicate :=
      function(
SString): Boolean
      begin
        
if Filter.Text '' then
          Result 
:= True
        
else
          
Result := AnsiContainsText(SFilter.Text);
      
end;
  
end;
end

Then I update my two sort functions to call UseFilterChange after they have done the sorting:

function TForm1.SortASCII(LeftRightTFMXObject): Integer;
begin
  Result 
:= CompareText((Left as TListBoxItem).Text, (Right as TListBoxItem).Text);
  
UseFilterChange(Self);
end;

function 
TForm1.SortNumeric(LeftRightTFMXObject): Integer;
begin
  Result 
:= (Left as TFileListBoxItem).FileSize - (Right as TFileListBoxItem).FileSize;
  
UseFilterChange(Self);
end

Download project

Full source:

unit Unit1;

interface

uses
  System
.SysUtilsSystem.TypesSystem.UITypesSystem.ClassesSystem.Variants,
  
FMX.TypesFMX.GraphicsFMX.ControlsFMX.FormsFMX.DialogsFMX.StdCtrls,
  
FMX.EditFMX.LayoutsFMX.ListBoxFMX.Controls.Presentation;

type
  TForm1 
= class(TForm)
    
FilterTEdit;
    
Label2TLabel;
    
FolderTEdit;
    
BrowseTButton;
    
OpenDialog1TOpenDialog;
    
ListBox1TListBox;
    
GroupBox1TGroupBox;
    
ASCIITRadioButton;
    
SizeTRadioButton;
    
UseFilterTCheckBox;
    
StyleBook1TStyleBook;
    
procedure BrowseClick(SenderTObject);
    
procedure FolderChange(SenderTObject);
    
procedure FormCreate(SenderTObject);
    
procedure FilterChangeTracking(SenderTObject);
    
procedure SortChange(SenderTObject);
    
procedure UseFilterChange(SenderTObject);
  private
    
SortFuncTFmxObjectSortCompare;
    function 
SortNumeric(LeftRightTFMXObject): Integer;
    function 
SortASCII(LeftRightTFMXObject): Integer;
  public
  
end;

var
  
Form1TForm1;

implementation
uses StrUtils
FMX.Objects;

{$R *.fmx}

type TFileListBoxItem 
= class(TListBoxItem)
  private
    
FFileSizeLongint;
    
procedure SetFileSize(const ValueLongint);
  protected
    
procedure ApplyStyle;override;
  
published
    property FileSize
Longint read FFileSize write SetFileSize;
end;

procedure TForm1.SortChange(SenderTObject);
begin
  
if ASCII.IsChecked then
    SortFunc 
:= SortASCII
  
else
    
SortFunc := SortNumeric;
  
ListBox1.Sort(SortFunc);
//  ListBox1.RealignContent;
end;

procedure TForm1.BrowseClick(SenderTObject);
begin
  
if OpenDialog1.Execute then
    Folder
.Text := ExtractFilePath(OpenDialog1.FileName);
end;

procedure TForm1.FilterChangeTracking(SenderTObject);
begin
  
if ListBox1.Count 0 then //This line needed for XE7
    
ListBox1.FilterPredicate := ListBox1.FilterPredicate;
end;

procedure TForm1.FolderChange(SenderTObject);
var 
SRTSearchRec;
  
FoundInteger;
  
ItemTFileListBoxItem;
begin
  ListBox1
.Clear;
  if 
DirectoryExists(Folder.Textthen
  begin
    
try
      
Found := FindFirst(Folder.Text+'\*.*'faAnyFileSR);
      while 
Found do
      
begin
        Item 
:= TFileListBoxItem.Create(Self);
        
Item.Text := SR.Name;
        
Item.FileSize := SR.Size;
        
Item.WordWrap := False;
        
Item.Trimming := TTextTrimming.Character;
        
ListBox1.AddObject(Item);
        
Found := FindNext(SR);
      
end;
      
ListBox1.Sort(SortFunc);
//      ListBox1.RealignContent;  //Needed in XE6
//      FilterChangeTracking(Filter); //Needed in XE6? *tk*
    
finally
      FindClose
(SR);
    
end;
  
end;
end;

procedure TForm1.FormCreate(SenderTObject);
begin
  SortFunc 
:= SortNumeric;
  
Size.IsChecked := True;
  
FilterChangeTracking(Filter);
end;

function 
TForm1.SortASCII(LeftRightTFMXObject): Integer;
begin
  Result 
:= CompareText((Left as TListBoxItem).Text, (Right as TListBoxItem).Text);
  
UseFilterChange(Self);
end;

function 
TForm1.SortNumeric(LeftRightTFMXObject): Integer;
begin
  Result 
:= (Left as TFileListBoxItem).FileSize - (Right as TFileListBoxItem).FileSize;
  
UseFilterChange(Self);
end;

procedure TForm1.UseFilterChange(SenderTObject);
begin
  
//AV setting FilterPredicate on an empty list in XE7.
  
if ListBox1.Count 0 then
    
EXIT;
  
ListBox1.FilterPredicate := nil;
  if 
UseFilter.IsChecked then
  begin
    ListBox1
.FilterPredicate :=
      function(
SString): Boolean
      begin
        
if Filter.Text '' then
          Result 
:= True
        
else
          
Result := AnsiContainsText(SFilter.Text);
      
end;
  
end
{  
else
    
ListBox1.FilterPredicate := nil};
end;

{ TFileListBoxItem }

procedure TFileListBoxItem
.ApplyStyle;
begin
  inherited
;
  
SetFileSize(FFileSize);
end;

procedure TFileListBoxItem.SetFileSize(const ValueLongint);
begin
  StylesData[
'FileSize':= IntToStr(Value);
  
FFileSize := Value;
end;

end

Styling Section added to the FireMonkey Guide

I’ve just finished uploading the styling section of the FireMonkey Guide.

This section starts with an explanation of how the styling in FireMonkey works, how styles are created and then applied by FireMonkey. It then moves through how to set styles at run-time in your application and finishes up with a brief description of the built in style designer.

As ever with the Guide I have attempted to distill out the essentials you need to know when using FireMonkey.

Mike

Prettier iOS Development on Windows

If, like me, you’re doing your Delphi iOS development on Windows then your probably making use of the compiler’s ability to compile and run your app on Win32. You’re probably also fed up with how dreadful your apps look during testing on Windows.

Wouldn’t it be great if you could load the proper iOS styles on Windows? Sadly the true iOS styles are locked away somewhere within Delphi. But there are a couple of custom styles available for iOS and it’s a simple process to load them into your app.

Start with your DPR file (select Project|View Source from the main menu). Add FMX.Styles to the uses list, and add the three lines shown below at the start of the code.

program MarginMarkup;

uses
  System
.StartUpCopy,
  
FMX.Forms,
  
FMX.Styles,
  
Calculator in 'Calculator.pas' {CalculatorForm},
  
Calculator.VM in 'Calculator.VM.pas';

{$R *.res}

begin
  {$IFDEF MSWINDOWS}
  TStyleManager
.SetStyleFromFile('C:\Users\Public\Documents\RAD Studio\12.0\Styles\iOS\iOSBlack.fsf');
  
{$ENDIF}
  Application
.Initialize;
  
Application.FormFactor.Orientations := [TFormOrientation.soPortraitTFormOrientation.soInvertedPortrait];
  
Application.CreateForm(TCalculatorFormCalculatorForm);
  
Application.Run;
end

The lines you need to add are the first three after the begin statement. The $IFDEF ensures that our code only compiles if Windows is the target. The line between loads the system style from the file specified (.fsf is a binary style file - you can also load .style files). The above code shows the default installation location for the files.

In addition to the iOSBlack style named above there’s also an iOSTransparent file in the same folder. There are also two premium styles available for download from Embarcadero’s registered downloads area, with each style available in both iOS 7 and non-iOS 7 versions.

The image below shows the iOS7Jet style running under Windows 8.

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

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<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

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.