Mega Code Archive
Url label [component]
<![CDATA[
//www.dronymc.cjb.net
//drony@mynet.com
// icq:266148308
unit UrlLabel;
interface
uses
Windows, SysUtils, Classes, Forms, StdCtrls, ShellAPI, Menus, Clipbrd,
Controls, Graphics;
const
crHand = 5;
type
TUrlLabel = class(TLabel)
private
FURL: string;
FOrigFontColor, FActiveColor: TColor;
Menu: TPopupMenu;
MenuItem: TMenuItem;
procedure OnMenuClick(Sender: TObject);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Click; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
published
property URL: string read FURL write FURL;
property ActiveColor: TColor read FActiveColor write FActiveColor default clPurple;
end;
procedure Register;
implementation
{---------------------------------------------------------------------------}
constructor TUrlLabel.Create( AOwner : TComponent );
begin
inherited Create(AOwner);
Screen.Cursors[crHand] := LoadCursor(HInstance, PChar('HAND'));
Cursor := crHand;
FActiveColor := clPurple;
with Font do begin
Color := clBlue;
Style := [fsUnderline];
end;
Menu := TPopupMenu.Create(Self);
MenuItem := TMenuItem.Create(Menu);
with MenuItem do begin
Caption := 'Copy';
OnClick := OnMenuClick;
end;
Menu.Items.Add(MenuItem);
PopupMenu := Menu;
end;
{---------------------------------------------------------------------------}
procedure TUrlLabel.Click;
var
TempURL: string;
begin
inherited Click;
if Trim(FURL) = '' then
TempURL := Caption
else
TempUrl := FURL;
if Trim(TempURL) <> '' then
ShellExecute(GetDesktopWindow(), 'open', PChar(TempURL), nil, nil, SW_SHOWNORMAL);
end;
{---------------------------------------------------------------------------}
procedure TUrlLabel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
FOrigFontColor := Font.Color;
Font.Color := FActiveColor;
end;
inherited;
end;
{---------------------------------------------------------------------------}
procedure TUrlLabel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
Font.Color := FOrigFontColor;
inherited;
end;
{---------------------------------------------------------------------------}
procedure TUrlLabel.OnMenuClick;
begin
Clipboard.AsText := Caption;
end;
{---------------------------------------------------------------------------}
destructor TUrlLabel.Destroy;
begin
Menu.Free;
inherited;
end;
{---------------------------------------------------------------------------}
procedure Register;
begin
RegisterComponents('Plus', [TUrlLabel]);
end;
{---------------------------------------------------------------------------}
end.
]]>