netlabel.pas

来自「delphi写的俄罗斯方块」· PAS 代码 · 共 111 行

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
    FHyperLinkKind:THyperLink;
    FHyperLink:string;
    FHLinkColor:TColor;
    FVLinkColor:TColor;
    FColor:TColor;
    procedure CMMouseEnter(var AMsg:TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var AMsg:TMessage); message CM_MOUSELEAVE;
     
    { Private declarations }
  protected
    { Protected declarations }
  public
     constructor Create(AOwner:TComponent); Override;
     procedure Click; override;
    { Public declarations }
  published
     property HyperLinkKind:THyperLink
                read FHyperLinkKind
                write FHyperLinkKind default hlMail;

     property HyperLink:string
                read FHyperLink
                write FHyperLink;

     property HLinkColor:TColor
                read FHLinkColor
                write FHLinkColor default clBlue;

     property VLinkColor:TColor
                read FVLinkColor
                write FVLinkColor default clNavy;

    { Published declarations }
  end;

procedure Register;

implementation

procedure TNetLabel.CMMouseEnter(var AMsg:TMessage);
begin
 FColor:=Font.Color;
 font.color:=FHLinkColor;
 font.style:=font.Style+[fsUnderLine];
end;

procedure TNetLabel.CMMouseLeave(var AMsg:TMessage);
begin
 font.Color:=FColor;
 font.Style:=font.Style-[fsUnderLine];
end;

constructor TNetLabel.Create(AOwner:TComponent);
begin
 inherited Create(AOwner);
 FHyperLinkKind:=hlMail;
 FHyperLink:='[e-mail]';
 FHLinkColor:=clBlue;
 FVLinkColor:=clNavy;
 with self do
 begin
  cursor:=crHandPoint;
  caption:=FHyperLink;
  font.Color:=clMaroon;
  FColor:=font.Color;
 end;
end;

procedure TNetLabel.Click;
begin
 inherited Click;
 if FHyperLink<>'' then
 begin
  case FHyperLinkKind of
       hlHTTP:ShellExecute(parent.handle,nil,pchar('http://'+FHyperLink),nil,
                           nil,sw_shownormal);
       hlMail:ShellExecute(parent.handle,nil,pchar('mailto:'+FHyperLink),nil,
                           nil,sw_shownormal);
       hlFTP:ShellExecute(parent.handle,nil,pchar('ftp://'+FHyperLink),nil,
                           nil,sw_shownormal);
       hlNews:ShellExecute(parent.handle,nil,pchar('news:'+FHyperLink),nil,
                           nil,sw_shownormal);
       hlGopher:ShellExecute(parent.handle,nil,pchar('gopher://'+FHyperLink),nil,
                           nil,sw_shownormal);
       hlTelnet:ShellExecute(parent.handle,nil,pchar('telnet:'+FHyperLink),nil,
                           nil,sw_shownormal);
 end;
 FColor:=FVLinkColor;
end;
end;

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

end.