Ver Mensaje Individual
  #8  
Antiguo 26-02-2010
Avatar de delphi.com.ar
delphi.com.ar delphi.com.ar is offline
Federico Firenze
 
Registrado: may 2003
Ubicación: Buenos Aires, Argentina *
Posts: 5.932
Reputación: 27
delphi.com.ar Va por buen camino
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 [-]

{ *********************************************************************** }
{                                                                         }
{   Copyright (c) Federico Firenze                                        }
{   Buenos Aires, Argentina                                               }
{   febrero de 2010                                                       }
{                                                                         }
{ *********************************************************************** }


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 [-]

{ *********************************************************************** }
{                                                                         }
{   Firesoft WinControls Components - UrlLabel                            }
{   Copyright (c) Federico Firenze                                        }
{   Buenos Aires, Argentina                                               }
{   enero de 2001                                                         }
{                                                                         }
{ *********************************************************************** }

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;

{ TUrlLabel }

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!
__________________
delphi.com.ar

Dedique el tiempo suficiente para formular su pregunta si pretende que alguien dedique su tiempo en contestarla.
Responder Con Cita