Como criar uma hiperligação...

[nunopicado]

unit NetLabel;

(******************************************************************************)
(*****************  NetLabel: Hyperlink Label for Delphi  *********************)
(*****************       Nuno Miguel Picado © 2012        *********************)
(******************************************************************************)

interface

uses
    StdCtrls, ShellAPI, Registry, Windows, Classes, Graphics, Controls, Messages;

type
    TNetLabel = class (TLabel)  // Nova classe baseada na TLabel
    Private
      Address:String;  // onde o endereço é guardado
      LinkClr:TColor;  // Guarda a cor do link antes de ser clicado
      HotClr:TColor;  // Guarda a cor do link depois de clicado
      function BrowseURL : boolean;  // Abre o explorador com o endereço guardado
      procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;  // Apanha a entrada do rato na área da NetLabel
      procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;  // Apanha a saida do rato na área da NetLabel
      Procedure SetURL(URL:String);  // Define o endereço URL
      procedure SetLColor(LinkColor: TColor);  // Define a cor do link antes de ser clicado
      procedure SetHColor(HotColor: TColor);  // Define a cor do link depois de ser clicado
    Public
      constructor Create(Sender:TComponent); Override;  // Constructor da classe
      procedure Click; Override;  // Apanha o evento OnClick da NetLabel
    Published
      property URL:String Read Address Write SetURL;  // Define e mostra o endereço da NetLabel
      property LinkColor:TColor Read LinkClr Write SetLColor;  // Define e mostra a cor da NetLabel antes de clicada
      property HotColor:TColor Read HotClr Write SetHColor;  // Define e mostra a cor da NetLabel depois de clicada
  end;

procedure Register;  // Regista o componente

implementation

constructor TNetLabel.Create(Sender:TComponent);
begin
     inherited;
     SetURL(''); // Define o endereço como não existente
     SetLColor(clBlue);
     SetHColor(clPurple);
     Font.Color:=LinkClr;
end;

procedure TNetLabel.SetLColor(LinkColor: TColor);
begin
     LinkClr:=LinkColor;
end;

procedure TNetLabel.SetHColor(HotColor: TColor);
begin
     HotClr:=HotColor;
end;

Procedure TNetLabel.SetURL(URL:String);
begin
     with Font do
          begin
               Color:=LinkClr;  // Define a cor como azul (não clickado)
               Style:=Font.Style-[fsUnderline];  // Remove o sublinhado do estilo da fonte, caso exista
          end;
     Address:=Url; // Define a variável URL
end;

procedure TNetLabel.Click;
begin
     inherited;
     if Address<>''
        then if BrowseURL  // Abre o Browser
                then Font.Color:=HotClr;  // Define a cor como purble (já clickado)
end;

procedure TNetLabel.CMMouseEnter(var Message: TMessage);
begin
     inherited;
     Font.Style:=Font.Style+[fsUnderline];  // Define o sublinhado
     Cursor:=crHandpoint;  // Define o cursor como HandPoint
end;

procedure TNetLabel.CMMouseLeave(var Message: TMessage);
begin
     inherited;
     Font.Style:=Font.Style-[fsUnderline];  // Remove o sublinhado
     Cursor:=crDefault;  // Define o cursor como Default
end;

function TNetLabel.BrowseURL : boolean;
var
   Browser:String;
begin
     Result:=True;
     Browser:='';

     // Verifica o browser padrão
     with TRegistry.Create do
          try
             RootKey:=HKEY_CLASSES_ROOT;
             Access:=KEY_QUERY_VALUE;
             if OpenKey('\htmlfile\shell\open\command', False)
                then Browser:=ReadString('');
             CloseKey;
          finally
             Free;
          end;

     // Se não houver browser padrão, termina
     if Browser=''
        then begin
                  Result:=False;
                  Exit;
             end;

     // Livra-se dos parametros do browser padrão
     Browser:=Copy(Browser,Pos('"',Browser)+1,999);
     Browser:=Copy(Browser,1,Pos('"',Browser)-1);

     // Chama o browser padrão com o URL como parâmetro
     ShellExecute(0,'open',PChar(Browser),PChar(Address),nil,SW_SHOW);
end;

procedure Register;
begin
     // Regista o componente no separador Internet
     RegisterComponents('Internet',[TNetLabel]);
end;

end.

Em Designtime:

1. Ir ao separador 'Internet'

2. Arrastar um TNetLabel para o local desejado

3. Definir as propriedades Caption (texto apresentado) e URL (Endereço) no Object Inspector

E voilá, está um link feito...

NOTA: Se não for definida a propriedade URL, o NetLabel age como um link interno, e terá de ser definido a sua acção no evento OnClick...

NOTA2: Pode-se alterar as cores padrão do componente, definindo as propriedades LinkColor (cor antes de clicado) e HotColor (cor depois de clicado)