aurllabl.pas

来自「delphi编程控件」· PAS 代码 · 共 111 行

unit aurllabl;
(*
 COPYRIGHT (c) RSD Software 1997 - 98
 All Rights Reserved.
*)

interface

uses Classes, Controls, StdCtrls, ShellAPI, Windows, Forms, Messages,
     graphics;

type
TAutoURLLabel = class(TCustomLabel)
private
  FOldText : String;
  FURL : String;
  procedure SetURL(Value : String);
  procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
protected
  procedure DblClick; override;
  procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
    X, Y: Integer); override;
  procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
public
  constructor Create(AOwner : TComponent); override;
published
  property Align;
  property Alignment;
  property AutoSize;
  property Caption;
  property Color;
  property DragCursor;
  property DragMode;
  property Enabled;
  property FocusControl;
  property Font;
  property ParentColor;
  property ParentFont;
  property ParentShowHint;
  property PopupMenu;
  property ShowAccelChar;
  property ShowHint;
  property Transparent;
  property Visible;
  property URL : String read FURL write SetURL;
  property OnClick;
  property OnDblClick;
  property OnDragDrop;
  property OnDragOver;
  property OnEndDrag;
  property OnMouseDown;
  property OnMouseMove;
  property OnMouseUp;
  property OnStartDrag;
end;

implementation
uses aclconst;
{$R aurllabl.res}

constructor TAutoURLLabel.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FOldText := '';
  Font.Color := clBlue;
  Font.Style := [fsUnderline];
  Width := 100;
end;

procedure TAutoURLLabel.SetURL(Value : String);
begin
  FURL := Value;
  Refresh;
end;

procedure TAutoURLLabel.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if(Caption <> '') then
    Cursor := acURLLabelCursor;
end;

procedure TAutoURLLabel.DblClick;
begin
  inherited;
  if(Caption <> '') then
    try
      ShellExecute( 0, PCHAR('open'),PChar(FURL), Nil, Nil,SW_RESTORE);
    except
    end;
end;

procedure TAutoURLLabel.MouseUp(Button: TMouseButton; Shift: TShiftState;
    X, Y: Integer);
begin
  inherited;
  DblClick;
end;

procedure TAutoURLLabel.CMTextChanged(var Message: TMessage);
begin
  if(FOldText = FURL) Or (FURL = '') then
    FURL := Text;
  FOldText := Text;
  Refresh;  
end;

initialization
  Screen.Cursors[acURLLabelCursor] := LoadCursor(HInstance, 'AUTOURLLABELCURSOR');
end.