Hyperlink Style Code

[Glenn9999]

I happened to do some playing around and got a label control to behave as an average hyperlink. Set the OnClick to act on the click in the main program. The rest enables switching a different color/style on entering the control and turning the cursor to the mouse hand.

Hopefully this will be of use to someone.

unit Hyperlink;

interface

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

type
  THyperlink = class(TLabel)
  private
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FEnterFont: TFont;
    FTempFont: TFont;  // place to save the old font when EnterFont is used
    procedure SetFont(Value: TFont);
  protected
    procedure CMMouseEnter(var Msg: TMessage); message CM_MouseEnter;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MouseLeave;
  public
    procedure VisitURL(URL: String);
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
  published
    property EnterFont: TFont read FEnterFont write SetFont;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
  end;

procedure Register;

implementation

Constructor THyperlink.Create(AOwner: TComponent);
// create the control.  This creates the extra Font objects and sets the cursor.
begin
  Inherited Create(AOwner);
  FEnterFont := TFont.Create;
  FTempFont := TFont.Create;
  Self.Cursor := crHandPoint;
end;

Destructor THyperlink.Destroy;
// free the Font Objects.
begin
  FEnterFont.Free;
  FTempFont.Free;
  Inherited;
end;

procedure THyperLink.VisitURL(URL: String);
// public procedure.  Sets shell execute for the URL passed.
begin
  ShellExecute(0, 'open', PChar(URL), nil, nil, SW_MAXIMIZE);
end;

procedure THyperLink.SetFont(Value:TFont);
// private procedure, sets the font from the design interface.
begin
  FEnterFont.Assign(Value);
end;

procedure THyperLink.CMMouseEnter(var Msg: TMessage);
// mouse enter message proc.  Switches current font with enter font and saves old font.
begin
  FTempFont.Assign(Self.Font);
  Self.Font.Assign(FEnterFont);
  if Assigned(FOnMouseEnter) then FOnMouseEnter(Owner);
end;

procedure THyperLink.CMMouseLeave(var Msg: TMessage);
// mouse leave proc.  Restores the original main font.
begin
  Self.Font.Assign(FTempFont);
  if Assigned(FOnMouseLeave) then FOnMouseLeave(Owner);
end;

procedure Register;
begin
  RegisterComponents('Samples', [THyperlink]);
end;

end.

It is not possible for anyone to acknowledge truth when their salary depends on them not doing it.

 

[whosrdaddy]

And now add the link visited color

/Daddy

-----------------------------------------------------
What You See Is What You Get
Never underestimate tha powah of tha google!