Posts from January 2013

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