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
Commenting is not available in this channel entry.