MessageBox e MessageDLG com personalização da fonte

25/05/2008

0

Pessoal eu procurei mais não encontrei uma MessageBox onde eu pudesse aumentar o tamanho da fonte
a messageBox padrão do Delphi tem um fonte muito pequena assim resolvi criar minha
propria messageBox e MessageDLG, pesquisando em alguns sites Internacionais
eu achei alguns funções e fiz uma mistura de funções e depois de umas modificações o resultado final ficou muito bom


type TObjectPosition = (brScreen, brScreenWorkArea, brMainForm, brActiveWindow);
TTypePosition = (bpCustom, bpTopLeft, bpTopCenter, bpTopRight,
bpCenterLeft, bpCenter, bpCenterRight,
bpBottomLeft, bpBottomCenter, bpBottomRight);

procedure PositionWindows(Wnd: Hwnd; FormActive: TObjectPosition; pos: TTypePosition; AtTop: Boolean);
var
aRect, r: TRect;
x, y, w, h: Integer;
tmp: HWnd;

function LMDDlgGetTargetRect(aRel: TObjectPosition): TRect;

function screenRect: TRect;
begin
result := Rect(0, 0, Screen.Width, Screen.Height);
end;

begin
case aRel of
brMainForm: if assigned(Application.MainForm) then
result := Application.MainForm.BoundsRect
else
result := screenRect;
brActiveWindow: if assigned(Screen.ActiveForm) then
result := Screen.ActiveForm.BoundsRect
else
result := screenRect;
brScreenWorkArea: SystemParametersInfo(SPI_GETWORKAREA, 0, {$IFDEF CLR}result{$ELSE}@result{$ENDIF}, 0);
else
result := screenRect;
end;

end;

begin
GetWindowRect(Wnd, r);
aRect := LMDDlgGetTargetRect(FormActive);

w := r.Right - r.Left;
h := r.Bottom - r.Top;
x := 0; y := 0;
case pos of
bpCustom, bpTopLeft: begin
x := aRect.Left;
y := aRect.Top;
end;
bpBottomLeft: begin
x := aRect.Left;
y := aRect.Bottom - h;
end;
bpCenterLeft: begin
x := aRect.Left;
y := aRect.Top + (((aRect.Bottom - aRect.Top) - h) div 2);
end;
bpTopRight: begin
x := aRect.Right - w;
y := aRect.Top;
end;
bpBottomRight: begin
x := aRect.Right - w;
y := aRect.Bottom - h;
end;
bpCenterRight: begin
x := aRect.Right - w;
y := aRect.Top + (((aRect.Bottom - aRect.Top) - h) div 2);
end;
bpTopCenter: begin
x := aRect.Left + (((aRect.Right - aRect.Left) - w) div 2);
y := aRect.Top;
end;
bpBottomCenter: begin
x := aRect.Left + (((aRect.Right - aRect.Left) - w) div 2);
y := aRect.Bottom - h;
end;
bpCenter: begin
x := aRect.Left + (((aRect.Right - aRect.Left) - w) div 2);
y := aRect.Top + (((aRect.Bottom - aRect.Top) - h) div 2);
end;
end;

if y + h > Screen.Height then y := aRect.Bottom - h;
if x + w > Screen.Width then x := aRect.Right - w;
if x < 0 then x := 0;
if y < 0 then y := 0;

if AtTop then tmp := HWND_TOP else tmp := 0;
SetWindowPos(Wnd, tmp, x, y, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);

end;



function MessageDlg(Msg, StrCaption: string; aType: TMsgDlgType = MtInformation;
AButtons: TMsgDlgButtons = [mbOK]; FontSize: Integer = 0; DefButton: TMOdalResult = mrok;
ObjectPosition: TObjectPosition = brScreenWorkArea; TypePosition: TTypePosition = bpCenter): Word;

var MForm: TForm;
lCaption, Label_Caption: TLabel;
Button_Alt: TButton;
N_Btns, Count_Btn, PadWidth, Spacer, BtnMax_Width, Width_Form1, Width_Form2, I: integer;
P1: array[byte] of Char;
Textsize, Butsize: TSize;
MDC: hDC;
CurMetrics: TTextMetric;
Curfont: HFont;
Msgrect: TRect;
Btn_Anteriro_Left, Btn_Anteriro_Width, BHeight, BWidth: integer;

begin
MForm := CreateMessageDialog(MSG, AType, Abuttons);
try
with MForm do begin
BorderStyle := bsDialog;
Ctl3D := True;
BorderIcons := [];
Caption := StrCaption;

Font.Name := ´Ariel´;
if FontSize = 0 then
Font.Size := Dlg_SizeFont else
Font.Size := FontSize;

if StrCaption = Emptystr then begin
if Atype = mtConfirmation then
Caption := ´Confirmação´
else if AType = mtWarning then
Caption := ´Aviso´
else if AType = mtError then
Caption := ´Erro´
else if AType = mtInformation then
Caption := ´Informação´;
end;

{$IFDEF Win32}
GetTextExtentPoint32(Canvas.Handle, P1, 52, Textsize);
{$ELSE}
GetTextExtentPoint(Canvas.Handle, P1, 52, Textsize);
{$ENDIF}
GetTextExtentPoint(Canvas.Handle, P1, 52, Textsize);

PadWidth := TextSize.CX div 52;
MDC := GetDC(0);
CurFont := SelectObject(MDC, Font.Handle);
GetTextMetrics(MDC, CurMetrics);
SelectObject(MDC, CurFont);
ReleaseDC(0, MDC);
end;

lCaption := TLabel.Create(MForm);
with lCaption do begin
Parent := Mform;
Left := 65;
Top := 8;
SetRect(MsgRect, 0, 0, Screen.Width div 2, 0);
DrawText(MForm.Canvas.Handle, PChar(Msg), -1, MsgRect, DT_CALCRECT or DT_WORDBREAK);
Width := Msgrect.Right;
Height := Msgrect.Bottom;
Autosize := False;
WordWrap := True;
Caption := Msg;
Visible := True;
end;

Label_Caption := TLabel.Create(MForm);
with Label_Caption do begin
Parent := Mform;
Autosize := False;
Caption := ´ACANCELAR´;
Visible := False;
end;

TLabel(Mform.FindComponent(´Message´)).Visible := False;
TButton(Mform.FindComponent(´YES´)).Caption := ´&Sim´;
TButton(Mform.FindComponent(´NO´)).Caption := ´&Não´;
TButton(Mform.FindComponent(´CANCEL´)).Caption := ´&Cancelar´;
TButton(Mform.FindComponent(´ABORT´)).Caption := ´&Abortar´;
TButton(Mform.FindComponent(´RETRY´)).Caption := ´&Repetir´;
TButton(Mform.FindComponent(´IGNORE´)).Caption := ´&Ignorar´;
TButton(Mform.FindComponent(´ALL´)).Caption := ´&Todos´;
TButton(Mform.FindComponent(´HELP´)).Caption := ´A&juda´;


BHeight := ((150 * Textsize.CY) div 100) - 5;
if BHeight < 25 then BHeight := 25;

Spacer := (Padwidth * 5) div 4;
Width_Form1 := lCaption.Left + lCaption.Width + (Padwidth * 3);

N_Btns := 0;
Width_Form2 := 0;
BtnMax_Width := 0;
for i := 0 to MForm.ComponentCount - 1 do begin
if ((MForm.Components[i] is TButton) and (MForm.Components[i] as TButton).Visible) then begin
Inc(N_Btns);

if (TButton(MForm.Components[i]).ModalResult = DefButton) then
MForm.ActiveControl := TWincontrol(MForm.Components[i]);

Button_Alt := (MForm.Components[i] as TButton);

(MForm.Components[i] as TButton).Top := (lCaption.Top + lCaption.Height + 25);

if MForm.Font.Size > 10 then begin
(MForm.Components[i] as TButton).Height := BHeight;
(MForm.Components[i] as TButton).Width := MForm.Canvas.TextWidth(Label_Caption.Caption) + 5;
end;

Width_Form2 := Width_Form2 + (MForm.Components[i] as TButton).Width;
BtnMax_Width := BtnMax_Width + (MForm.Components[i] as TButton).Width;

end;
end;

Width_Form2 := Width_Form2 + (Spacer * 2) + (Padwidth * 4);
BtnMax_Width := BtnMax_Width + (Spacer * 2);


if Width_Form2 > Width_Form1 then
MForm.Clientwidth := Width_Form2 else
MForm.Clientwidth := Width_Form1;


Count_Btn := 0;
for i := 0 to MForm.ComponentCount - 1 do begin
if ((MForm.Components[i] is TButton) and (MForm.Components[i] as TButton).Visible) then begin

Inc(Count_Btn);

if N_Btns = 1 then begin
(MForm.Components[i] as TButton).Left := (MForm.ClientWidth div 2) - ((MForm.Components[i] as TButton).Width div 2);
Break;
end;

if Count_Btn = 1 then begin
(MForm.Components[i] as TButton).Left := (MForm.ClientWidth - BtnMax_Width) div 2;
end else begin
(MForm.Components[i] as TButton).Left := Btn_Anteriro_Left + Btn_Anteriro_Width + Spacer;
end;

Btn_Anteriro_Left := (MForm.Components[i] as TButton).Left;
Btn_Anteriro_Width := (MForm.Components[i] as TButton).Width;

end;
end;

Mform.ClientHeight := Button_Alt.Top + Button_Alt.Height + 15;

PositionWindows(MForm.Handle, ObjectPosition, TypePosition, true);
Result := MForm.Showmodal;
finally
MForm.Free;
end;

end;

Exemplo de Uso

// Tamanho da Fonte
var Dlg_SizeFont = 11;

// Esse exemplo traz como padrão MtInformation e button OK
messageDLG(´Exemplo de Mensagem´,´´);

messagedlg(´Exemplo de Mensagem´, ´Informação do Programa´, MtInformation, [Mbyes], Dlg_SizeFont);

if MessageDlg(´Exemplo de Mensagem´, ´Informação do Programa´, mtinformation, [mbYes, mbNo], Dlg_SizeFont, mrno) = idyes then // Focu no Botão ´Não´


//Possionando a mensagem no centro no Top do form que esta ativo
messagedlg(´Exemplo de Mensagem´, ´Informação do Programa´, MtInformation, [Mbyes, Mbno], Dlg_SizeFont, brMainForm, bpTopCenter);


Luciano_f

Luciano_f

Responder

Posts

25/05/2008

Luciano_f

Pessoal se alguem encontrar algum bug ou fizer alguma melhoria na função entre em contato

email luapfr@yahoo.com.br

Grato.
Luciano França.


Responder

17/01/2014

Mauro Brondi

Muito obrigado Luciano.
Está funcionando redondo aqui.
Flw!
Responder

Assista grátis a nossa aula inaugural

Assitir aula

Saiba por que programar é uma questão de
sobrevivência e como aprender sem riscos

Assistir agora

Utilizamos cookies para fornecer uma melhor experiência para nossos usuários, consulte nossa política de privacidade.

Aceitar