一个超级连接控件

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.