Link Label Component

Problem/Question/Abstract:

I have seen many tips on how to call the default browser and open a web page, yet no component in DKB that allows to simply be placed on a form at design time.

Answer:

This component was developed for the German-language forum Delphi-PRAXiS by myself. There is not much to say about it. Simply copy the source code into a new Delphi unit save it and install the component in Delphi.

Afterwards you may place it on your form, set link and caption, adjust the colors for Hot-Link, Visited and Unvisited. Just like a link within your HTML. You may place a link to an e-mail address also, by simply preceding the email address with a mailto:.

======================== CODE START ========================

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* Unit Name : uDPLinkLabel
* Copyright : Copyright © 2001, 2002 by gate(n)etwork. All Rights Reserved.
* Author    : Daniel Wischnewski
* Freeware  : This source is released under the Mozilla Public License. It may
*             be reproduced, as long as all references to its original source
*             are maintained.
*             The most recent version is publicly available at
*             http://www.Delphi-PRAXiS.net
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

//: Enth�lt eine Internetlink-Label-Komponente f�r die Mitglieder der Delphi-PRAXiS.
unit uDPLinkLabel;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  //: Komponente zur Bereitstellung von Links innerhalb von Delphi-Anwendungen
  TDPLinkLabel = class(TCustomLabel)
  private
    FHoverLinkFont: TFont;
    FHyperLink: string;
    FLinkFont: TFont;
    FMouseHover: Boolean;
    FVisited: Boolean;
    FVisitedLinkFont: TFont;
    procedure FontChanged(Sender: TObject);
    procedure SetHoverLinkFont(Value: TFont);
    procedure SetHyperLink(Value: string);
    procedure SetLinkFont(Value: TFont);
    procedure SetVisited(Value: Boolean);
    procedure SetVisitedLinkFont(Value: TFont);
    procedure UpdateLinkFont;
  protected
    procedure Click; override;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExecuteHyperLink(aLink: string = '');
  published
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property Caption;
    property Color;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FocusControl;
    property HoverLinkFont: TFont read FHoverLinkFont write SetHoverLinkFont;
    property HyperLink: string read FHyperLink write SetHyperLink;
    property Layout;
    property LinkFont: TFont read FLinkFont write SetLinkFont;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property ParentBiDiMode;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowAccelChar;
    property ShowHint;
    property Transparent;
    property Visible;
    property Visited: Boolean read FVisited write SetVisited;
    property VisitedLinkFont: TFont read FVisitedLinkFont write
      SetVisitedLinkFont;
    property WordWrap;
  end;

procedure Register;

implementation

uses
  ShellAPI;

procedure Register;
begin
  RegisterComponents('Delphi-PRAXiS', [TDPLinkLabel]);
end;

{ TDPLinkLabel }

constructor TDPLinkLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // create default link font object
  FLinkFont := TFont.Create;
  FLinkFont.OnChange := FontChanged;
  FLinkFont.Color := clBlue;
  FLinkFont.Style := [fsUnderline];
  // set inherited font
  Font := LinkFont;
  // create visit link font object
  FVisitedLinkFont := TFont.Create;
  FVisitedLinkFont.OnChange := FontChanged;
  FVisitedLinkFont.Color := clPurple;
  FVisitedLinkFont.Style := [fsUnderline];
  // create hover link font object
  FHoverLinkFont := TFont.Create;
  FHoverLinkFont.OnChange := FontChanged;
  FHoverLinkFont.Color := clRed;
  FHoverLinkFont.Style := [fsUnderline];
  // initialize vars
  FMouseHover := False;
  FVisited := False;
  Caption := 'Delphi-PRAXiS';
  FHyperLink := 'http://www.Delphi-PRAXiS.net';
  // override initialization of previous vars
  Cursor := crHandPoint;
end;

destructor TDPLinkLabel.Destroy;
begin
  inherited Destroy;
  // free link font objects
  FLinkFont.Free;
  FHoverLinkFont.Free;
  FVisitedLinkFont.Free;
end;

procedure TDPLinkLabel.Click;
begin
  // the onClick method will be overriden only, if a link is assigned to the
  // Link property of the component and no custom on-click handler is assigned
  if (not Assigned(OnClick)) and (Action = nil) and (ActionLink = nil) and (
    HyperLink <> '') then
    // call link
    ExecuteHyperLink
  else
    // work standard control click routine
    inherited;
end;

procedure TDPLinkLabel.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  // mouse enters link - hover color effective
  FMouseHover := True;
  UpdateLinkFont;
end;

procedure TDPLinkLabel.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  // mouse leaves link - hover color not effective anymore
  FMouseHover := False;
  UpdateLinkFont;
end;

procedure TDPLinkLabel.ExecuteHyperLink(aLink: string = '');
var
  UseLink: string;
begin
  // set link for execution
  if Trim(aLink) = '' then
    UseLink := Trim(HyperLink)
  else
    UseLink := Trim(aLink);
  // check link data
  if Trim(UseLink) = '' then
    // raise exception on empty link
    raise Exception.Create('No link for launching web browser.');
  // load default browser with link
  ShellExecute(0, nil, PChar(HyperLink), nil, nil, SW_SHOW);
  // HyperLink was visited, no special link passed
  if Trim(aLink) <> '' then
    Visited := True;
end;

procedure TDPLinkLabel.FontChanged(Sender: TObject);
begin
  // need to inform preceding class of possible changes in font
  UpdateLinkFont;
end;

procedure TDPLinkLabel.SetHoverLinkFont(Value: TFont);
begin
  FHoverLinkFont.Assign(Value);
  UpdateLinkFont;
end;

procedure TDPLinkLabel.SetHyperLink(Value: string);
begin
  if FHyperLink <> Value then
  begin
    FHyperLink := Value;
    Visited := False;
    if Caption = '' then
      Caption := HyperLink;
  end;
end;

procedure TDPLinkLabel.SetLinkFont(Value: TFont);
begin
  FLinkFont.Assign(Value);
  UpdateLinkFont;
end;

procedure TDPLinkLabel.SetVisited(Value: Boolean);
begin
  if FVisited <> Value then
  begin
    FVisited := Value;
    UpdateLinkFont;
  end;
end;

procedure TDPLinkLabel.SetVisitedLinkFont(Value: TFont);
begin
  FVisitedLinkFont.Assign(Value);
  UpdateLinkFont;
end;

procedure TDPLinkLabel.UpdateLinkFont;
begin
  // assign font property the appropriate font data
  if FMouseHover then
    Font := HoverLinkFont
  else if Visited then
    Font := VisitedLinkFont
  else
    Font := LinkFont;
end;

end.

========================= CODE END =========================