Siendo haber descubierto este hilo tan tarde, pero en fin, ¡encuentras cuándo buscas! La suerte es que estaba aquí y con otro tema que había encontrado de Marco Cantu, he fabricado una nueva solución, sin que se bloquee la aplicación por el 'sleep'.
También he adaptado el mensaje diferenciándolo del Caption del form y dimensionando varias líneas.
El botton2 usa la Unit de Dec.
Gracias a todos por vuestras aportaciones.
Os pego el codigo de mi form por si a alguien le pueda valer:
Código Delphi
[-]unit Pal;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type TMiTimer = class(TTimer) private
procedure Evento(Sender: TObject); end;
type
TfPal = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
public
procedure MsgPopup(const titulo, msg:string; const wait: integer);
end;
var
fPal: TfPal;
Timer: TMiTimer;
fmMsg: TForm;
implementation
uses UMsgPopup;
procedure TMiTimer.Evento(Sender: TObject);
begin
FreeAndNil(fmMsg);
end;
{$R *.dfm}
procedure TfPal.MsgPopup(const titulo, msg:string; const wait: integer);
var
i,max: integer;
lbMsg: TLabel;
panel: TRect;
L: byte;
function Lineas(const msg: string): byte;
var
I,C: Byte;
S: string;
begin
I:= 0;
S:= msg;
C:= pos(#13,S);
while C > 0 do
begin
Inc(I);
S:= Copy (S, C+1, length(S));
C:= pos(#13,S);
end;
result:= I;
end;
begin
fmMsg := TForm.Create(nil);
try
with fmMsg do
begin
Width := 350;
L:= Lineas(msg);
if L = 0 then
Height := 110
else
Height:= 70 + 60 * L;
Color := clWhite;
Caption:=' '+ titulo;
SystemParametersInfo(48, 0, @panel, 0);
Top := panel.Bottom;
BorderStyle := bsToolWindow;
FormStyle := fsStayOnTop;
lbMsg:=TLabel.Create(fmMsg);
Timer:= TMiTimer.Create(fmMsg);
Timer.Enabled:= False;
Timer.Interval:= wait;
Left := panel.Right-fmMsg.Width-2;
max :=panel.Bottom-fmMsg.Height-2;
with lbMsg do
begin
Top := 30;
Left := 10;
Height:=30;
Parent := fmMsg;
AutoSize := True;
Caption := msg;
Font.Size := 14;
Font.Name := 'Arial';
Font.Color := clRed;
Alignment:= taCenter;
Font.Style:=[fsBold];
Width := fmMsg.Width;
end;
Show;
i := Top;
while(i>=max)do
begin
Top := i;
Dec(i,2);
Refresh ;
end;
end;
finally
Timer.Enabled:= True;
Timer.OnTimer := Timer.Evento;
end;
end;
procedure TfPal.Button1Click(Sender: TObject);
var
Mensaje: string;
begin
Mensaje:= 'Mensaje desde fPal'+#13+
'por 5 seg' +#13+
'y tres líneas';
MsgPopup('Mensaje Título', Mensaje , 5000);
end;
procedure TfPal.Button2Click(Sender: TObject);
var
Mensaje: string;
begin
Mensaje:= 'Mensaje desde Unit'+#13+
'sólo 3 seg y 2 líneas';
Msn('Mensaje Título', Mensaje , 3000);
end;
end.
¡Feliz año!