用Delphi实现超级链接

2000年第26期《家用电脑》有一篇文章介绍了用VC在对话框中实现超级连接，而
用Delphi实现起来更加简单，而且一劳永逸，下面我们就来实现这一控件：
THotLabel。

unit HotLabel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ShellApi;

type
//THotLabel从TCustomLabel继承
THotLabel = class(TCustomLabel)
private
{ Private declarations }
//属性变量
FHotColor : TColor;
FClickColor : TColor;
FSavColor : TColor;
//标志变量
FMouseMove : boolean;
FMouseDown : boolean;
//缺省Click函数
procedure LabelClick(Sender: TObject);
protected
{ Protected declarations }
procedure Loaded; override;
public
procedure MouseDown(Button:TMouseButton;Shift:TShiftState;
X, Y: Integer);override;
procedure MouseUp(Button:TMouseButton;Shift:TShiftState;
X, Y: Integer);override;
procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
constructor Create(AOwner: TComponent);override;
published
//使TCustomLabel的下列属性可见，可参照TLabel
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 Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Transparent;
property Layout;
property Visible;
property WordWrap;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
//新增属性，当鼠标移动到THotLabel上时的颜色
property HotColor: TColor read FHotColor write FHotColor;
//新增属性，当在THotLable上按下鼠标时的颜色
property ClickColor: TColor read FClickColor write FClickColor;
end;

//控件注册函数
procedure Register;

implementation

procedure Register;
begin
RegisterComponents('XDCtls', [THotLabel]);
end;

{ THotLabel }

constructor THotLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//给缺省字体加上下划线
Font.Style := Font.Style + [fsUnderline];
//保存字体颜色
FSavColor := Font.Color;
//鼠标移动到THotLabel上时为蓝色
FHotColor := clBlue;
//按下鼠标为红色
FClickColor := clRed;
//缺省光标为手形
Cursor := crHandPoint;
//标志变量
FMouseMove := false;
FMouseDown := false;
end;

//鼠标移入控件范围时，改变字体颜色
procedure THotLabel.CMMouseEnter(var msg: TMessage);
begin
inherited;
FMouseMove := true;
if not FMouseDown then
FSavColor := Font.Color;
Font.Color := FHotColor;
end;

//鼠标离开控件范围时，改变字体颜色
procedure THotLabel.CMMouseLeave(var msg: TMessage);
begin
inherited;
FMouseMove := False;
if FMouseDown then begin
Font.Color := FClickColor;
end else begin
Font.Color := FSavColor;
end;
end;

//按下鼠标时，改变颜色
procedure THotLabel.MouseDown(Button: TMouseButton;
Shift: TShiftState; X,Y: Integer);
begin
FMouseDown := true;
inherited MouseDown(Button,Shift,X,Y);
if not FMouseMove then
FSavColor := Font.Color;
Font.Color := FClickColor;
end;

//放开鼠标时，改变颜色
procedure THotLabel.MouseUp(Button: TMouseButton;
Shift: TShiftState; X,Y: Integer);
begin
FMouseDown := false;
inherited MouseUp(Button,Shift,X,Y);
if FMouseMove then begin
Font.Color := FHotColor;
end else begin
Font.Color := FSavColor;
end;
end;

//缺省的Click事件处理，ShellExecute的说明见第26期《家用电脑》
//《在对话框中实现超级链接》，或参照Delphi帮助。
procedure THotLabel.LabelClick(Sender: TObject);
begin
//如果Caption中包含'http://'，则浏览指定地址。
if UpperCase(Copy(Caption,1,7)) = 'HTTP://' then begin
ShellExecute(Application.handle,'open',PChar(Caption),
nil,nil,SW_NORMAL);
//如果Caption中包含'mailto:'，则按EMAIL发送
end else if UpperCase(Copy(Caption,1,7)) = 'MAILTO:' then begin
ShellExecute(Application.handle,'open',PChar(Caption),
nil,nil,SW_NORMAL);
//如果Caption中不包含'mailto:'，但包含'@'，同样按EMAIL发送。
end else if Pos('@',Caption)<>0 then begin
ShellExecute(Application.handle,'open',PChar('mailto:'+Caption),
nil,nil,SW_NORMAL);
end;
end;

//控件装载过程中如果用户没有给OnClick事件赋值，则使用缺省处理函数。
procedure THotLabel.Loaded;
begin
inherited Loaded;
//没有OnClick事件，由LabelClick处理。
if not (csDesigning in Componentstate) then begin
if not Assigned(OnClick) then OnClick := LabelClick;
end;
end;

end.

有了这个控件，只要在设计对话框时鼠标一点，放置一个THotLabel，
然后设置Caption属性为你的主页地址或EMAIL地址，不用再加一行代码就
实现了超级链接。当然你也可以自己定义Click事件实现其他功能，甚至
可以把THotLabel当作一个特殊的按钮来用，大家自己试试吧。
上述程序在PWin97+Delphi5.0运行通过。