netlabel.~pas

可以实现链接、发EMail等功能的TLabel扩展控件

unit NetLabel;

interface

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

type
  THyperLink=(hlHTTP,hlMail,hlTelnet,hlGopher,hlNews,hlFTP);
type
  TNetLabel = class(TLabel)
  private
    { Private declarations }
  FHyperLinkKind:THyperLink;
  FHyperLinkMouseEnter:string;
  FHyperLinkMouseLeave:string;
  FHyperLink:string;
  FHLinkColor         :TColor;
  FVLinkColor         :TColor;
  FColor              :TColor;
  procedure CMMouseEnter(var AMsg:TMessage);message CM_MOUSEENTER;
  procedure CMMouseLeave(var AMsg:TMessage);message CM_MOUSELEAVE;
  procedure SetCaption  (value:string);
  procedure SetHyperLink  (value:string);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create (AOwner:TComponent);Override;
    procedure   Click;Override;
  published
    { Published declarations }
    property  HyperLinkKind:THyperLink read FHyperLinkKind write FHyperLinkKind default hlMail;
    property  HyperLink:string read FHyperLink write SetHyperLink;
    property  HyperLinkMouseEnter:string read FHyperLinkMouseEnter write FHyperLinkMouseEnter;
    property  HyperLinkMouseLeave:string read FHyperLinkMouseLeave  write SetCaption;
    property  VLinkColor:TColor  read FVLinkColor write FVLinkColor default clMaroon;
    property  HLinkColor:TColor  read FHLinkColor write FHLinkColor default clNavy;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Cumtom', [TNetLabel]);
end;

procedure TNetLabel.SetHyperLink(value:string);
begin
 if FHyperLink<>value then begin
 FHyperLink:=value;
 Hint:=FHyperLink;
 end;
end;

procedure TNetLabel.SetCaption(value:string);
begin
 if FHyperLinkMouseLeave<>value then begin
 FHyperLinkMouseLeave:=value;
 Caption:=FHyperLinkMouseLeave;
 end;
end;

procedure TNetLabel.CMMouseEnter(var AMsg:TMessage);
begin
  if FHyperLinkMouseEnter<>'' then
  Caption:=FHyperLinkMouseEnter;
  FColor:=Font.Color;
  Font.Color:=FHLinkColor;
  Font.Style:=Font.Style+[fsUnderLine];
  end;

procedure TNetLabel.CMMouseLeave(var AMsg:TMessage);
begin
  if FHyperLinkMouseLeave<>'' then
  Caption:=FHyperLinkMouseLeave;
  Font.Color:=FColor;
  Font.Style:=Font.Style-[fsUnderLine];
  end;
constructor TNetLabel.Create (AOwner:TComponent);
begin
  Inherited Create(AOwner);
  FHyperLinkKind:=hlMail;
  AutoSize:=True;
  ShowHint:=True;
  if FHyperLink='' then
  FHyperLink:='[e-mail]';
  Hint:=FHyperLink;
  if FHyperLinkMouseLeave='' then
  FHyperLinkMouseLeave:='[e-mail]';
  if FHyperLinkMouseEnter='' then
  FHyperLinkMouseEnter:='写信告诉我您的建议!      ';
  FVLinkColor:=clMaroon;
  FHLinkColor:=clNavy;
  with self do begin
  cursor:=crHandPoint;
  Caption:=FHyperLinkMouseLeave;
  Font.Color:=clBlue;
  FColor:=Font.Color;
  end;
end;
procedure TNetLabel.Click;
begin
 Inherited Click;
 if FHyperLinkMouseLeave<>'' then begin
  case FHyperLinkKind of
  hlHTTP:ShellExecute(0,nil,PChar('http://'+FHyperLink),
                      nil,nil,SW_SHOWNORMAL);
  hlMail:ShellExecute(0,nil,PChar('mailto:'+FHyperLink),
                      nil,nil,SW_SHOWNORMAL);
  hlFTP:ShellExecute(0,nil,PChar('ftp://'+FHyperLink),
                      nil,nil,SW_SHOWNORMAL);
  hlNews:ShellExecute(0,nil,PChar('news:'+FHyperLink),
                      nil,nil,SW_SHOWNORMAL);
  hlgopher:ShellExecute(0,nil,PChar('gopher://'+FHyperLink),
                      nil,nil,SW_SHOWNORMAL);
  hlTelnet:ShellExecute(0,nil,PChar('telnet'+FHyperLink),
                      nil,nil,SW_SHOWNORMAL);
  end;
  FColor:=FVLinkColor;
 end;
end;

end.