showmessage con link

[petete2008]

Quiero sacar un cartel con una frase en html de forma que al hacer click se me abrá el enlace ( en mi caso ese enlace apuntará siempre a una imagen en una ruta de mi disco C y por lo tanto se abrirá el programa de fotos que tenga asociado).

Por ejemplo :
ShowMessage('Haga clic aqui para ver la foto.');

donde 'clic' llevaría el enlace.

¿es posible?
Gracias

[delphi.com.ar]

Si preguntas si existe alguna función que ya haga esto... lo desconozco, posiblemente algun fragmento de código abierto debe haber por ahí... pero lo mas sencillo es crear tu propio diálogo, bien mediante un TForm visualmente o investiga el código de los diálogos de Delphi para hacerlo mediante código.

Saludos!

[Neftali [Germán.Estévez]]

Si se trata de hacerlo en un formulario Delphi, yo a veces lo simulo utilizando un Label. Color azul, subrayado, CursorType (crHandPoint) y programando el OnMouseDown para que ejecute un ShellExecute.

[petete2008]

entonces entiendo que debo abrir un cuadro de dialogo (form) y ahí personalizarlo como yo quiera.
Buscaré información de como abrir una ventana form y luego al cerrar que se libere la memoria utilizada correctamente.
Muchas gracias

[[movorack]]

Primero creas el otro formulario... FormLinkDlg... darle la apariencia que desees y las propiedades necesarias para que se maneje como lo esperas. luego agregas la unidad a los uses y puedes crear una función o manejarlo directamente desde un procedimiento en especifico.

creo que con una función así podria funcionar:

Código Delphi [-]
function LinkDlg(Caption, Text, Link : String) : TModalResult;
  var
    mResult : TModalResult;
    Dialog : TFormLinkDlg;
begin
  Dialog := TFormLinkDlg.Create(Application);
  try
    Dialog.Caption := Caption;
    Dialog.Text := Text;
    Dialog.Link := Link;
    mResult := Dialog.ShowModal;
  finally
    Dialog.Free;
  end;
  Result := mResult;
end;

luego solo seria llamar la funcion

Código Delphi [-]
  LinkDlg("Fotos", "Su foto está cargada", "C:\fotos\foto.jpg");

[delphi.com.ar]

Empezado por movorack

Código Delphi [-]
function LinkDlg(Caption, Text, Link : String) : TModalResult;
  var
    mResult : TModalResult;
    Dialog : TFormLinkDlg;
begin
  Dialog := TFormLinkDlg.Create(Application);
  try
    Dialog.Caption := Caption;
    Dialog.Text := Text;
    Dialog.Link := Link;
    mResult := Dialog.ShowModal;
  except
    Dialog.Free;
  end;
  Result := mResult;
end;

No tendría que ir un except, sino un finally porque en este caso el form solo se liberará si se produce un error.

Saludos!

[[movorack]]

tienes razón... gracias... mientras respondias vi el error y corregí...

[delphi.com.ar]

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!