urllabel.pas

来自「搞笑俄罗斯方块这个程序由delphi制作而成。」· PAS 代码 · 共 136 行

{*************************************************}
{          URL Lable Component v1.0               }
{                                                 }
{          Author: YouJing                        }
{          EMail:  [e-mail]                 }
{          URL: http://proglife.126.com           }
{          Last Modify: 2001-8-15                 }
{                                                 }
{*************************************************}
unit URLLabel;

interface

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

type
  TTextMode = (tmSimple, tmURL, tmEmail);
  TTextState = TFont;

  TURLLabel = class(TLabel)
  private
    { Private declarations }
    FMode: TTextMode;
    FMouseInState: TTextState;
    FMouseOutState: TTextState;
    FUrl: String;
    FEMail: String;
    FMouseInBkColor: TColor;
    FMouseOutBkColor: TColor;
    procedure SetMouseOut(Value: TTextState);
    procedure SetMouseIn(Value: TTextState);
    procedure SetFont(Value: TTextState);
    procedure SetMode(Value: TTextMode);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    procedure CMMouseIn(var Message: TMessage); Message CM_MOUSEENTER;
    procedure CMMouseOut(var Message: TMessage); Message CM_MOUSELEAVE;
    procedure CMMouseClick(var Message: TMessage); Message WM_LBUTTONDOWN;
  published
    { Published declarations }
    property Mode: TTextMode read FMode Write SetMode default tmUrl;
    property MouseIn: TTextState read FMouseInState write SetMouseIn;
    property MouseOut: TTextState read FMouseOutState write SetMouseOut;
    property URL: string read FUrl write FUrl;
    property EMail: string read FEMail write FEMail;
    property MouseInBkColor: TColor read FMouseInBkColor write FMouseInBkColor default clBtnFace;
    property MouseOutBkColor: TColor read FMouseOutBkColor write FMouseOutBkColor default clBtnFace;
  end;

procedure Register;

implementation

//-------------------------------------------------------------------------
procedure Register;
begin
  RegisterComponents('EasySoft', [TURLLabel]);
end;

//-------------------------------------------------------------------------
constructor TURLLabel.Create(AOwner: TComponent);
begin
   FMode := tmUrl;
   FMouseInState := TTextState.Create;
   FMouseOutState := TTextState.Create;
   FMouseInBkColor := clBtnFace;
   FMouseOutBkColor := clBtnFace;
   inherited;
   SetMode(FMode);
end;

//-------------------------------------------------------------------------
procedure TURLLabel.SetMode(Value: TTextMode);
begin
   FMode := Value;
   if Value=tmSimple then
      Cursor := crDefault
   else
      Cursor := crHandPoint;
end;

//-------------------------------------------------------------------------
procedure TURLLabel.SetFont(Value: TTextState);
begin
   Font.Assign(Value);
end;

//-------------------------------------------------------------------------
procedure TURLLabel.SetMouseIn(Value: TTextState);
begin
   FMouseInState.Assign(Value);
end;

//-------------------------------------------------------------------------
procedure TURLLabel.SetMouseOut(Value: TTextState);
begin
   SetFont(Value);
   FMouseOutState.Assign(Value);
   Color := FMouseOutBkColor;
   Invalidate;
end;

//-------------------------------------------------------------------------
procedure TURLLabel.CMMouseIn(var Message: TMessage);
begin
   SetFont(FMouseInState);
   Color := FMouseInBkColor;
   Invalidate;
end;

//-------------------------------------------------------------------------
procedure TURLLabel.CMMouseOut(var Message: TMessage);
begin
   SetFont(FMouseOutState);
   Color := FMouseOutBkColor;
   Invalidate;
end;

//-------------------------------------------------------------------------
procedure TURLLabel.CMMouseClick(var Message: TMessage);
begin
   case FMode of
      tmURL:
         ShellExecute(0,'open',PChar('http://'+FUrl),'','',SW_SHOWNORMAL);
      tmEMail:
         ShellExecute(0,'open',PChar('mailto:'+FEMail),'','',SW_SHOWNORMAL);
   end;
end;

end.