unit HyperLabel;

interface

uses

 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

 Shellapi, StdCtrls;

type

 THyperLabel = class(TLabel)

 private

   { Private declarations }

   FHoverFont: TFont;

   FHoverColor: TColor;

   FHoverCursor: TCursor;

   FOldCursor: TCursor;

   FOldFont: TFont;

   FOldColor: TColor;

   FOldScreenCursor: TCursor;

   FOnMouseEnter: TNotifyEvent;

   FonMouseLeave: TNotifyEvent;

   FURL: string;

   FHCursor: HCURSOR;

   procedure FSetHoverFont(value: TFont);

   procedure FSetHoverColor(value: TColor);

   procedure FSetOnMouseLeave(value: TNotifyEvent);

   procedure FSetOnMouseEnter(value: TNotifyEvent);

   procedure FSetHoverCursor(value: TCursor);

   procedure FSetURL(value: string);

 protected

   { Protected declarations }

   procedure cmmouseenter(var Msg: TMessage); message CM_MOUSEENTER;

   procedure cmmouseleave(var msg: TMessage); message CM_MOUSELEAVE;

 public

   { Public declarations }

   constructor Create(AOwner: TComponent); override;

   destructor Destroy; override;

   procedure Click; override;

 published

   { Published declarations }

   property URL: string read FURL write FSetURL;

   property HoverFont: TFont read FHoverFont write FSetHoverFont;

   property HoverColor: TColor read FHoverColor write FSetHoverColor stored true default clBtnFace;

   property HoverCursor: TCursor read FHoverCursor write FSetHoverCursor stored true default crHandPoint;

   property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FSetOnMouseEnter;

   property OnMouseLeave: TNotifyEvent read FonMouseLeave write FSetOnMouseLeave;

 end;

procedure Register;

implementation

procedure Register;

begin

 RegisterComponents('Samples', [THyperLabel]);

end;

{ THyperLabel }

procedure THyperLabel.Click;

var

 Temp: string;

begin

 inherited;

 Temp := Copy(FURL, 1, 5);

 if UpperCase(Temp) = 'HTTP:' then

   ShellExecute(Parent.Handle, 'open', 'explorer.exe', pchar(FURL), nil, SW_SHOW)

 else

   ShellExecute(Parent.Handle, 'open', pchar(FURL), nil, nil, SW_SHOW);

end;

procedure THyperLabel.cmmouseenter(var Msg: TMessage);

begin

 FOldFont.Assign(Font);

 Font.Assign(FHoverFont);

 FOldColor := Color;

 Color := FHoverColor;

 FOldCursor := Cursor;

 FHCursor := LoadCursor(0, IDC_HAND);

 FOldScreenCursor := Screen.Cursors[crHandPoint];

 Screen.Cursors[crHandPoint] := FHCursor;

 Cursor := crHandPoint;

 if Assigned(FOnMouseEnter) then

   FOnMouseEnter(Self);

end;

procedure THyperLabel.cmmouseleave(var Msg: TMessage);

begin

 Font.Assign(FOldFont);

 Color := FOldColor;

 DestroyCursor(FHCursor);

 Screen.Cursors[crHandPoint] := FOldScreenCursor;

 Cursor := FOldCursor;

 if Assigned(FonMouseLeave) then

   FOnMouseLeave(Self);

end;

constructor THyperLabel.Create(AOwner: TComponent);

begin

 inherited;

 URL := 'mailto:Kingron@163.net';

 FHoverFont := TFont.Create;

 FOldFont := TFont.Create;

 FHoverFont.Assign(Font);

 FHoverFont.Color := clBlue;

 FHoverFont.Style := FHoverFont.Style + [fsUnderLine];

 FHoverColor := clBtnFace;

 FHoverCursor := crHandPoint;

end;

destructor THyperLabel.Destroy;

begin

 FHoverFont.Free;

 FOldFont.Free;

 inherited;

end;

procedure THyperLabel.FSetHoverColor(value: TColor);

begin

 if FHoverColor <> value then

   FHoverColor := value;

end;

procedure THyperLabel.FSetHoverCursor(value: TCursor);

begin

 if value <> FHoverCursor then

   FHoverCursor := value;

end;

procedure THyperLabel.FSetHoverFont(value: TFont);

begin

 FHoverFont.Assign(value);

end;

procedure THyperLabel.FSetOnMouseEnter(value: TNotifyEvent);

begin

 if @FOnMouseEnter <> @value then

   FOnMouseEnter := Value;

end;

procedure THyperLabel.FSetOnMouseLeave(value: TNotifyEvent);

begin

 if @FonMouseLeave <> @value then

   FonMouseLeave := value;

end;

procedure THyperLabel.FSetURL(value: string);

begin

 if Uppercase(value) <> Uppercase(FURL) then

   FURL := value;

end;

end.