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:


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

LinkDlg("Fotos", "Su foto está cargada", "C:\fotos\foto.jpg");

[delphi.com.ar]

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í... :D:D

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



{ *********************************************************************** }
{ }
{ 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:

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:


{ *********************************************************************** }
{ }
{ 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!