Bueno.. me agarraron generoso y escribí un poco de código. Básicamente es la reimplementación de la función CreateMessageDialog con dos parámetros agregados que utiliza un componente que escribí hace unos años, puedes cambiarlo por el que mas te guste:
Código Delphi
[-]
unit URLDialogs;
interface
uses
Dialogs, Forms, SysUtils;
function CreateMessageDialogURL(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; const URLText: string; const URLPath: string): TForm;
function MessageDlgPosHelpURL(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
const HelpFileName: string; const URLText: string; const URLPath: string): Integer;
function MessageDlgURL(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; const URLText: string;
const URLPath: string): Integer;
function MessageDlgPosURL(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; const URLText: string;
const URLPath: string): Integer;
procedure ShowMessagePosURL(const Msg: string; X, Y: Integer; const URLText: string;
const URLPath: string);
procedure ShowMessageURL(const Msg: string; const URLText: string;
const URLPath: string);
procedure ShowMessageFmtURL(const Msg: string; Params: array of const;
const URLText: string; const URLPath: string);
implementation
uses
URLLabel, Controls, Classes, Math;
function CreateMessageDialogURL(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; const URLText: string; const URLPath: string): TForm;
var
i: Integer;
begin
Result := CreateMessageDialog(Msg, DlgType, Buttons);
if URLPath <> '' then
begin
with TUrlLabel.Create(Result) do
begin
Parent := Result;
for i := 0 to Result.ControlCount -1 do
if Result.Controls[i] is TWinControl then
TWinControl(Result.Controls[i]).Anchors := [];
if URLText = '' then
Caption := '...'
else
Caption := URLText;
URL := URLPath;
if Result.ClientWidth < Width then
Result.ClientWidth := Min(Width, Screen.Width);
Align := alBottom;
Alignment := taRightJustify;
Result.Height := Result.Height + (Height div 2);
end;
end;
end;
function MessageDlgPosHelpURL(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
const HelpFileName: string; const URLText: string; const URLPath: string): Integer;
begin
with CreateMessageDialogURL(Msg, DlgType, Buttons, URLText, URLPath) do
try
HelpContext := HelpCtx;
HelpFile := HelpFileName;
if X >= 0 then Left := X;
if Y >= 0 then Top := Y;
if (Y < 0) and (X < 0) then Position := poScreenCenter;
Result := ShowModal;
finally
Free;
end;
end;
function MessageDlgURL(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; const URLText: string;
const URLPath: string): Integer;
begin
Result := MessageDlgPosHelpURL(Msg, DlgType, Buttons, HelpCtx, -1, -1, '',
URLText, URLPath);
end;
function MessageDlgPosURL(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; const URLText: string;
const URLPath: string): Integer;
begin
Result := MessageDlgPosHelpURL(Msg, DlgType, Buttons, HelpCtx, X, Y, '',
URLText, URLPath);
end;
procedure ShowMessagePosURL(const Msg: string; X, Y: Integer; const URLText: string;
const URLPath: string);
begin
MessageDlgPosURL(Msg, mtCustom, [mbOK], 0, X, Y, URLText, URLPath);
end;
procedure ShowMessageURL(const Msg: string; const URLText: string;
const URLPath: string);
begin
ShowMessagePosURL(Msg, -1, -1, URLText, URLPath);
end;
procedure ShowMessageFmtURL(const Msg: string; Params: array of const;
const URLText: string; const URLPath: string);
begin
ShowMessageURL(Format(Msg, Params), URLText, URLPath);
end;
end.
El uso es igual que las funciones de diálogos de delphi:
Código Delphi
[-]
ShowMessageURL('Hola', 'ver el directorio raíz del disco...', 'c:\');
...
MessageDlgURL('¿Esta usted seguro?', mtConfirmation, mbYesAllNoAllCancel, 0, 'ver foro...', 'http://www.clubdelphi.com');
Aquí val el TURLLabel:
Código Delphi
[-]
unit UrlLabel;
interface
uses
StdCtrls, Windows, Messages, ShellAPI, Classes, Graphics, Controls, Forms, ExtCtrls;
type
TUrlLabel = class(TLabel)
private
FURL: string;
FUnvisitedColor: TColor;
FActivatedColor: TColor;
FVisitedColor: TColor;
FHoveredColor: TColor;
FCanHover: Boolean;
FVisited: Boolean;
FDown: Boolean;
procedure SetUnvisitedColor(Value: TColor);
procedure SetVisitedColor(Value: TColor);
procedure SetHoveredColor(Value: TColor);
procedure SetCanHover(Value: Boolean);
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
public
constructor Create(AOwner: TComponent); override;
published
property Cursor default crHandPoint;
property URL: string read FURL write FURL;
property UnvisitedColor: TColor read FUnvisitedColor write SetUnvisitedColor default clBlue;
property ActivatedColor: TColor read FActivatedColor write FActivatedColor default clRed;
property VisitedColor: TColor read FVisitedColor write SetVisitedColor default clNavy;
property HoveredColor: TColor read FHoveredColor write SetHoveredColor default clRed;
property CanHover: Boolean read FCanHover write SetCanHover default False;
end;
procedure OpenURL(const URL: string);
implementation
procedure OpenURL(const URL: string);
{$IFNDEF WIN32}
var
Buffer: array[0..255] of Char;
{$ENDIF}
begin
if URL <> '' then
{$IFNDEF WIN32}
ShellExecute(Application.Handle, 'open',
StrPCopy(Buffer, URL), nil, nil, SW_SHOW)
{$ELSE}
ShellExecute(Application.Handle, 'open',
PChar(URL), nil, nil, SW_SHOW)
{$ENDIF}
end;
constructor TUrlLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Font.Color := clBlue;
Font.Style := [fsUnderline];
FUnvisitedColor := clBlue;
FActivatedColor := clRed;
FVisitedColor := clNavy;
FHoveredColor := clRed;
Cursor := crHandPoint;
end;
procedure TUrlLabel.CMFontChanged(var Message: TMessage);
begin
inherited;
if not FCanHover and not FDown then
begin
if not FVisited then
FUnvisitedColor := Font.Color
else
FVisitedColor := Font.Color;
end;
end;
procedure TUrlLabel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
if Button = mbLeft then
begin
FDown := True;
Font.Color := FActivatedColor;
end;
end;
procedure TUrlLabel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if Button = mbLeft then
begin
if (X >= 0) and (Y >= 0) and (Y <= Height) and (X <= Width) then
begin
if FDown then
begin
FVisited := True;
if FCanHover then
Font.Color := FHoveredColor
else
Font.Color := FVisitedColor;
if URL <> '' then
OpenURL(FURL)
else
OpenURL(Caption);
end;
end else
begin
if FVisited then
Font.Color := FVisitedColor
else
Font.Color := FUnvisitedColor;
end;
FDown := False;
end;
end;
procedure TUrlLabel.SetUnvisitedColor(Value: TColor);
begin
if FUnvisitedColor <> Value then
begin
if not FVisited then
Font.Color := Value
else
FUnvisitedColor := Value;
end;
end;
procedure TUrlLabel.SetVisitedColor(Value: TColor);
begin
if FVisitedColor <> Value then
begin
if not FVisited then
FVisitedColor := Value
else
Font.Color := Value;
end;
end;
procedure TUrlLabel.SetHoveredColor(Value: TColor);
begin
if FHoveredColor <> Value then
FHoveredColor := Value;
end;
procedure TUrlLabel.SetCanHover(Value: Boolean);
begin
if FCanHover <> Value then FCanHover := Value;
if Value then
Font.Style := Font.Style - [fsUnderline]
else
Font.Style := Font.Style + [fsUnderline];
end;
procedure TUrlLabel.CMMouseEnter(var Message: TMessage);
begin
inherited;
if CanHover then
Font.Style := Font.Style + [fsUnderline];
if FDown then
Font.Color := FActivatedColor
else if FCanHover then
Font.Color := FHoveredColor;
end;
procedure TUrlLabel.CMMouseLeave(var Message: TMessage);
begin
inherited;
if FCanHover then
Font.Style := Font.Style - [fsUnderline];
if FVisited then
Font.Color := FVisitedColor
else
Font.Color := FUnvisitedColor;
end;
end.
Si no quieres los botones y quieres un solamente que aparezca un URLLabel, simplemente puedes implementar un diálogo mas sencillo.
Saludos!