unit Unit1;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Shape1: TShape;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.Button1Click(Sender: TObject);
var
  F: TForm;
  MSG: Tlabel;
  Borda: TShape;
begin
  F := TForm.Create(Application);
  F.BorderStyle := bsNone;
  F.Position := poDesktopCenter;
  F.Width := 100;
  F.Height := 16; // até aqui criamos o form
 
  Borda := TShape.Create(Application);
  Borda.Parent := F;
  Borda.Align := alClient; // uma borda envolta do form
 
  MSG := Tlabel.Create(Application);
  MSG.Parent := F;
  MSG.Transparent := true;
  MSG.AutoSize := false;
  MSG.Width := 98;
  MSG.Caption := 'Aguarde';
  MSG.Alignment := taCenter; // label com a mensagem "Aguarde"
 
  F.Show;
  F.Update;
 
  // Aqui você coloca os procedimentos desejados
  Sleep(5000);   // exemplo de processamento, aguarda 5 segundos
 
  F.Free; // E finalmente libera a janela
end;
 
end.

{ *************************************************************************
                     Copyright (C) Ivan Cesar Ferreira
                         email: ivancesarf@gmail.com
                         skype: proadvanced
                         whatsapp: (74) 99943-1865
***************************************************************************
  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at
 
     http://www.apache.org/licenses/LICENSE-2.0
 
  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
*************************************************************************** }
 
{ exemplo de uso
  // mensagem de pergunta simples, com parâmetro para exibir ou nao´ícone de atenção
  if TDialogMessage.ConfirmMessage('Mensagem de pergunta', True ) then
 
 
  // mensagem personalizada, com várias versões overloads
  if TDialogMessage.ShowMessageDialog(
    'Mensagem a ser exibida',
    'Título da janela',
    mtInformation, // [mtWarning, mtError, mtInformation, mtConfirmation, mtCustom]
    ['Caption do botão 1', 'Caption do botão 2', 'Caption do botão N'] // array de strings que será criado um botão para cada caption passado
    1, // índice do botão que deve ser o Default (quando clicado ENTER) - começa em 1 e não em zero
    1 // índice do botão acionado quando clicado no ESC - começa em 1 e não em zero
    ) = 1 /*retorno do índice do botão clicado -  começa em 1 e não em zero*/ then
 
 
  // mensagem de aguarde, cria uma tela bloqueando tudo o que for digitado e clicado
  with TDialogMessage do
  begin
    ShowWaitMessage('Mensagem de aguarde ...');
    try
      // seu código demorado
    finally
      // sempre que usar essa versão (sem método anônimo), deve chamar o closeWaitMessage
      // senão a tela de aguarde apenas fechará se outro formulário for chamado com ShowModal
      CloseWaitMessage;
    end;
  end;
 
 
  TDialogMessage.ShowWaitMessage('Aguarde ...',
  procedure
  begin
    // seu código demorado
    // aqui não precisa chamar o CloseWaitMessage, pois o método quando terminado já fechará a tela
  end);
 
 
  // mensagem de erro, que aborta o código após ela, caso exista
  TDialogMessage.ShowExceptionDialog('Mensagem de erro.');
 
  // pode tmb passar uma excepton como parametro
  ....
  except
    on E: Exception do
      TDialogMessage.ShowExceptionDialog(E);
  end;
 
  // mensagem de erro que apenas exibe a mensage, mas continua o código após ela, caso exista
  TDialogMessage.ShowErrorMessage('Mensagem de erro.');
  }
 
unit Vcl.DialogMessage;
 
interface
 
uses
  System.Classes,
  System.Sysutils,
  System.Math,
  Winapi.Windows,
  Winapi.Messages,
  Winapi.ShellApi,
  Vcl.Consts,
  Vcl.Dialogs,
  Vcl.Forms,
  Vcl.Controls,
  Vcl.Graphics,
  Vcl.StdCtrls,
  Vcl.ExtCtrls,
  Vcl.Buttons,
  Vcl.AppEvnts;
 
type
  TDialogMessage = class sealed
  private
    class procedure InternalFree;
  public
    constructor Create; reintroduce;
    class function GetInstance: TDialogMessage;
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
 
    // base dialog
    class function ShowCustomMessageDialog(
      const AMessage, ATitle: string;
      const ADialogType: TMsgDlgType;
      const AButtons: array of string;
      const ADefaultIndex, ACancelIndex: Integer;
      const AHelpIndex, AHelpContext: Longint;
      const AHelpFileName: string;
      const APositionX, APositionY: Integer): Integer; overload;
 
    // with positioning
    class function ShowCustomMessageDialogPos(
      const AMessage, ATitle: string;
      const ADialogType: TMsgDlgType;
      const AButtons: array of string;
      const ADefaultIndex, ACancelIndex: Integer;
      const APositionX, APositionY: Integer): Integer;
 
    // with specializations
    class function ShowMessageDialog(
      const AMessage, ATitle: string;
      const ADialogType: TMsgDlgType;
      const AButtons: array of string;
      const ADefaultIndex, ACancelIndex: Integer): Integer; overload;
 
    class function ShowMessageDialog(
      const AMessage: string;
      const ADialogType: TMsgDlgType;
      const AButtons: array of string;
      const ADefaultIndex, ACancelIndex: Integer): Integer; overload;
 
    class function ShowMessageDialog(
      const AMessage, ATitle: string;
      const ADialogType: TMsgDlgType;
      const AButtons: array of string): Integer; overload;
    class function ShowMessageDialog(
      const AMessage: string;
      const ADialogType: TMsgDlgType;
      const AButtons: array of string): Integer; overload;
    class procedure ShowMessageDialog(const AMessage, ATitle: string); overload;
    class procedure ShowMessageDialog(const AMessage: string); overload;
 
    // confirmation message
    class function ConfirmMessage(const AMessage: string; AWarningIcon: Boolean): Boolean; overload;
    class function ConfirmMessage(const AMessage: string): Boolean; overload;
 
    // error message
    class procedure ShowErrorMessage(AErrorMessage: string); overload;
    class procedure ShowExceptionDialog(AErrorMessage: string); overload;
    class procedure ShowExceptionDialog(AException: Exception); overload;
 
    // wait message
    class function ShowWaitMessage(const AMessage: string = ''): TDialogMessage; overload;
    class function ShowWaitMessage(const AMessage: string; AProc: TProc): TDialogMessage; overload;
    class function ShowWaitMessage(const AMessage: string; AFunc: TFunc<Boolean>): TDialogMessage; overload;
    class function CloseWaitMessage: TDialogMessage;
  end;
 
function DialogMessage: TDialogMessage;
 
{ direct access }
function ShowMessageDialog(const AMessage, ATitle: string; const ADialogType: TMsgDlgType; const AButtons: array of string; const ADefaultIndex, ACancelIndex: Integer): Integer; overload;
function ShowMessageDialog(const AMessage: string; const ADialogType: TMsgDlgType; const AButtons: array of string; const ADefaultIndex, ACancelIndex: Integer): Integer; overload;
function ShowMessageDialog(const AMessage, ATitle: string; const ADialogType: TMsgDlgType; const AButtons: array of string): Integer; overload;
function ShowMessageDialog(const AMessage: string; const ADialogType: TMsgDlgType; const AButtons: array of string): Integer; overload;
procedure ShowMessageDialog(const AMessage, ATitle: string); overload;
procedure ShowMessageDialog(const AMessage: string); overload;
function ConfirmMessage(const AMessage: string; AWarningIcon: Boolean): Boolean; overload;
function ConfirmMessage(const AMessage: string): Boolean; overload;
procedure ShowErrorMessage(AErrorMessage: string); overload;
procedure ShowExceptionDialog(AErrorMessage: string); overload;
procedure ShowExceptionDialog(AException: Exception); overload;
function ShowWaitMessage(const AMessage: string = ''): TDialogMessage; overload;
function ShowWaitMessage(const AMessage: string; AProc: TProc): TDialogMessage; overload;
function ShowWaitMessage(const AMessage: string; AFunc: TFunc<Boolean>): TDialogMessage; overload;
function CloseWaitMessage: TDialogMessage;
 
implementation
 
function MsgDlgInstance: TDialogMessage;
begin
  Result := TDialogMessage.GetInstance;
end;
 
function DialogMessage: TDialogMessage;
begin
  Result := MsgDlgInstance;
end;
 
 
 
type
  TResizableLabel = class(TLabel)
  protected
    FTextHeight, FTextWidth: integer;
    function GetCaption: TCaption;
    procedure SetCaption(ACaption: TCaption);
    function GetFont: TFont;
    procedure SetFont(AFont: TFont);
  public
    procedure Resize; override;
    property Caption: TCaption read GetCaption write SetCaption;
    property Font: TFont read GetFont write SetFont;
  end;
 
  TMessageDialog = class(TForm)
  private
    CanCloseForm: Boolean;
    ScrollBoxMsg: TScrollBox;
    PanelCaption: TPanel;
    PanelButtons: TPanel;
    LabelMessage: TResizableLabel;
    LabelCopy   : TLabel;
    ImageIcon   : TImage;
    ButtonArray : array of TButton;
    ExeVersion  : string;
    procedure ButtonClick(Sender: TObject);
  protected
    procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure CustomLabelClick(Sender: TObject);
    procedure CustomCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure CustomWriteTextToClipBoard(AText: string);
    procedure CustomPanelCaptionOnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure CustomScrollBoxMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
    procedure CustomScrollBoxMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
    function FormToText: string;
  public
    constructor CreateNew(AOwner: TComponent); reintroduce;
  end;
 
  TWaitForm = class(TForm)
  private
    PanelContainer: TPanel;
    LabelMessage  : TLabel;
    AppEvents     : TApplicationEvents;
  protected
    procedure CustomAppEventsModalBegin(Sender: TObject);
  end;
 
  { TResizableLabel }
 
function TResizableLabel.GetCaption: TCaption;
begin
  Result := inherited Caption;
end;
 
function TResizableLabel.GetFont: TFont;
begin
  Result := inherited Font;
end;
 
function GetTextHeight(const AText: string; AFont: TFont): Integer;
var
  LBitmap: TBitmap;
begin
  LBitmap := TBitmap.Create;
  try
    LBitmap.Canvas.Font := AFont;
    Result := LBitmap.Canvas.TextHeight(AText);
  finally
    LBitmap.Free;
  end;
end;
 
function GetTextWidth(const AText: string; AFont: TFont): Integer;
var
  LBitmap: TBitmap;
begin
  LBitmap := TBitmap.Create;
  try
    LBitmap.Canvas.Font := AFont;
    Result := LBitmap.Canvas.TextWidth(AText);
  finally
    LBitmap.Free;
  end;
end;
 
procedure TResizableLabel.Resize;
var
  LNum: Double;
begin
  inherited;
  if AutoSize then
  begin
    if (FTextHeight = 0) or (FTextWidth = 0) then
    begin
      // lazy evaluation, we re evaluate every time the caption or font changes
      FTextWidth := GetTextWidth(Caption, Font);
      FTextHeight := GetTextHeight(Caption, Font);
    end;
    // TODO: there is still one bug here, set alCenter and make the last word long enough so it cant always wrapped to the line before,
    // even though there is globally enough space
    try
      LNum := (Height / FTextHeight) - (FTextWidth / Width);
    except
      LNum := -1;
    end;
    // if LNum is greater then 1 it means we need an extra line, if it is lower then zero it means there is an extra line
    if (LNum > 1) or (LNum < 0) then
    begin
      // just doing this all the time will cause it to really resize and will break alTop matching the whole space
      AutoSize := False;
      AutoSize := True;
    end;
  end;
end;
 
procedure TResizableLabel.SetCaption(ACaption: TCaption);
begin
  FTextWidth := GetTextWidth(ACaption, Self.Font);
  FTextHeight := GetTextHeight(ACaption, Self.Font);
  inherited Caption := ACaption;
end;
 
procedure TResizableLabel.SetFont(AFont: TFont);
begin
  FTextWidth := GetTextWidth(Caption, AFont);
  FTextHeight := GetTextHeight(Caption, AFont);
  inherited Font := AFont;
end;
 
{ TMessageDialog }
 
procedure TMessageDialog.ButtonClick(Sender: TObject);
begin
  CanCloseForm := True;
  ModalResult := TButton(Sender).Tag;
end;
 
procedure TMessageDialog.CustomCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := CanCloseForm;
end;
 
procedure TMessageDialog.CustomLabelClick(Sender: TObject);
begin
  MessageBeep(0);
  CustomWriteTextToClipBoard(FormToText);
end;
 
procedure TMessageDialog.CustomPanelCaptionOnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    ReleaseCapture;
    Self.Perform($0112, $F012, 0);
  end;
end;
 
procedure ScrollBoxRollDown(const AScollBox: TScrollBox);
begin
  if AScollBox.VertScrollBar.IsScrollBarVisible then
    with AScollBox.VertScrollBar do
    begin
      if (Position <= (Range - Increment)) then
        Position := Position + Increment
      else
        Position := Range - Increment;
    end;
end;
 
procedure ScrollBoxRollUp(const AScollBox: TScrollBox);
begin
  if AScollBox.VertScrollBar.IsScrollBarVisible then
    with AScollBox.VertScrollBar do
    begin
      if (Position >= Increment) then
        Position := Position - Increment
      else
        Position := 0;
    end;
end;
 
procedure TMessageDialog.CustomScrollBoxMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  ScrollBoxRollDown(TScrollBox(Sender));
end;
 
procedure TMessageDialog.CustomScrollBoxMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  ScrollBoxRollUp(TScrollBox(Sender));
end;
 
procedure TMessageDialog.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Shift = [ssCtrl] then
  begin
    if Key = Word('C') then
    begin
      MessageBeep(0);
      CustomWriteTextToClipBoard(FormToText);
    end;
    if Key = VK_HOME then
      ScrollBoxMsg.VertScrollBar.Position := 0;
    if Key = VK_END then
      ScrollBoxMsg.VertScrollBar.Position := ScrollBoxMsg.VertScrollBar.Range;
  end;
 
  if Key = VK_DOWN then
  begin
    ScrollBoxMsg.SetFocus;
    ScrollBoxRollDown(ScrollBoxMsg);
  end;
  if Key = VK_UP then
  begin
    ScrollBoxMsg.SetFocus;
    ScrollBoxRollUp(ScrollBoxMsg);
  end;
end;
 
function DoGetExeVersion: string;
type
  pFFI = ^VS_FIXEDFILEINFO;
var
  F       : pFFI;
  dwHandle: Cardinal;
  dwLen   : Cardinal;
  szInfo  : Cardinal;
  pchData : PWideChar;
  pchFile : PWideChar;
  ptrBuff : Pointer;
  strFile : string;
begin
  strFile := Application.ExeName;
  pchFile := StrAlloc(Length(strFile) + 1);
  StrPcopy(pchFile, strFile);
  szInfo := GetFileVersionInfoSize(pchFile, dwHandle);
  Result := '';
  if szInfo > 0 then
  begin
    pchData := StrAlloc(szInfo + 1);
    if GetFileVersionInfo(pchFile, dwHandle, szInfo, pchData) then
    begin
      VerQueryValue(pchData, '\', ptrBuff, dwLen);
      F := pFFI(ptrBuff);
      Result := Format('v%d.%d.%d (%.3d) %s', [
          HiWord(F^.dwFileVersionMs),
          LoWord(F^.dwFileVersionMs),
          HiWord(F^.dwFileVersionLs),
          LoWord(F^.dwFileVersionLs),
          {$IFDEF DEBUG} 'Debug'{$ELSE} ''{$ENDIF}]).Trim;
    end;
    StrDispose(pchData);
  end;
  StrDispose(pchFile);
end;
 
procedure TMessageDialog.CustomWriteTextToClipBoard(AText: string);
var
  LHandle : THandle;
  LPointer: Pointer;
begin
  if OpenClipBoard(0) then
  begin
    try
      LHandle := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, ByteLength(AText) + SizeOf(WideChar));
      try
        LPointer := GlobalLock(LHandle);
        try
          Move(PWideChar(AText)^, LPointer^, ByteLength(AText) + SizeOf(WideChar));
          EmptyClipBoard;
          SetClipboardData(CF_UNICODETEXT, LHandle);
        finally
          GlobalUnlock(LHandle);
        end;
      except
        GlobalFree(LHandle);
        raise;
      end;
    finally
      CloseClipBoard;
    end;
  end
  else
    raise Exception.Create('Não foi possível acessar a área de transferência.');
end;
 
function TMessageDialog.FormToText: string;
var
  DividerLine   : string;
  ButtonCaptions: string;
  I             : Integer;
begin
  DividerLine := StringOfChar('-', 80) + sLineBreak;
  for I := 0 to ComponentCount - 1 do
    if Components[I] is TButton then
      ButtonCaptions := ButtonCaptions + AnsiQuotedStr(TButton(Components[I]).Caption, '|') + StringOfChar(' ', 3);
  ButtonCaptions := StringReplace(ButtonCaptions, '&', '', [rfReplaceAll]) + sLineBreak;
  Result :=
    DividerLine +
    ExtractFileName(ParamStr(0)) +
    ' -> ' +
    Caption +
    sLineBreak +
    DividerLine +
    LabelMessage.Caption +
    sLineBreak +
    DividerLine +
    ButtonCaptions +
    DividerLine;
end;
 
procedure DoCenterControl(AControl: TControl; AVertical, AHorizontal: Boolean);
var
  LeftValue  : Integer;
  TopValue   : Integer;
  HeightValue: Integer;
  WidthValue : Integer;
begin
  HeightValue := AControl.Height;
  WidthValue := AControl.Width;
  LeftValue := (AControl.Parent.Width div 2) - (WidthValue div 2);
  TopValue := (AControl.Parent.Height div 2) - (HeightValue div 2);
  if AVertical then
    AControl.Top := TopValue;
  if AHorizontal then
    AControl.Left := LeftValue;
end;
 
constructor TMessageDialog.CreateNew(AOwner: TComponent);
const
  SMsgDlgCopyToClipBrd     = 'Copiar';
  SHintMsgDlgCopyToClipBrd = 'Copia a mensagem para a área de transferência';
var
  NonClientMetrics: TNonClientMetrics;
begin
  inherited CreateNew(AOwner);
  NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
  AutoScroll := False;
  BiDiMode := Application.BiDiMode;
  Font.Name := 'Tahoma';
  Font.Size := 9;
  // Font.Color := clWhite;
  // Canvas.Font := Font;
  ShowHint := True;
  PopupMode := pmAuto;
  Position := poScreenCenter;
  ActiveControl := nil;
  BorderIcons := [];
  // BorderStyle := bsDialog;
  BorderStyle := bsNone;
  Color := $00EAEAEA; // $00949494;
  // Font.Color := clWhite;
  // Font.Style := [fsBold];
  AlphaBlend := True;
  AlphaBlendValue := 235;
  KeyPreview := True;
  OnKeyDown := CustomKeyDown;
  OnCloseQuery := CustomCloseQuery;
 
  // panel caption
  PanelCaption := TPanel.Create(Self);
  PanelCaption.Name := 'PanelCaption';
  PanelCaption.Parent := Self;
  PanelCaption.Align := alTop;
  PanelCaption.Height := 25;
  PanelCaption.Alignment := taCenter;
  PanelCaption.BevelOuter := bvNone;
  PanelCaption.ShowCaption := True;
  PanelCaption.TabStop := False;
  PanelCaption.ParentBackground := False;
  PanelCaption.ParentColor := False;
  PanelCaption.Color := $004F4F4F; // $00787878; // $00949494;
  PanelCaption.Font.Color := clWhite;
  PanelCaption.Font.Style := [fsBold];
  PanelCaption.Cursor := crDrag;
  PanelCaption.OnMouseDown := CustomPanelCaptionOnMouseDown;
 
  // image icon
  ImageIcon := TImage.Create(Self);
  ImageIcon.Name := 'ImageIcon';
  ImageIcon.Parent := Self;
  ImageIcon.Left := 16;
  ImageIcon.Top := 16 + PanelCaption.Height;
  ImageIcon.Width := 32;
  ImageIcon.Height := 32;
  ImageIcon.Transparent := True;
  ImageIcon.IncrementalDisplay := True;
 
  // panel button
  PanelButtons := TPanel.Create(Self);
  PanelButtons.Name := 'PanelButtons';
  PanelButtons.Parent := Self;
  PanelButtons.Align := alBottom;
  PanelButtons.Height := 41;
  PanelButtons.BevelOuter := bvNone;
  PanelButtons.Caption := '';
  PanelButtons.ShowCaption := False;
  PanelButtons.TabStop := False;
  // PanelButtons.Color := clBtnFace;
  PanelButtons.ParentBackground := True;
  PanelButtons.ParentColor := True;
 
  // label copy to clibrd
  LabelCopy := TLabel.Create(Self);
  LabelCopy.Name := 'LabelCopy';
  LabelCopy.Parent := PanelButtons;
  LabelCopy.Left := ImageIcon.Left;
  LabelCopy.AutoSize := True;
  LabelCopy.Transparent := True;
  LabelCopy.Layout := tlCenter;
  LabelCopy.Font.Style := [fsUnderline];
  LabelCopy.Font.Size := 7;
  LabelCopy.Cursor := crHandPoint;
  LabelCopy.Caption := SMsgDlgCopyToClipBrd;
  LabelCopy.Hint := SHintMsgDlgCopyToClipBrd;
  LabelCopy.OnClick := CustomLabelClick;
 
  // scrollbox
  ScrollBoxMsg := TScrollBox.Create(Self);
  ScrollBoxMsg.Name := 'ScrollBoxMsg';
  ScrollBoxMsg.Parent := Self;
  ScrollBoxMsg.ParentBackground := True;
  ScrollBoxMsg.ParentColor := True;
  ScrollBoxMsg.BorderStyle := bsNone;
  ScrollBoxMsg.TabStop := False;
  ScrollBoxMsg.AlignWithMargins := True;
  ScrollBoxMsg.Margins.Top := 16;
  ScrollBoxMsg.Margins.Left := 64;
  ScrollBoxMsg.Margins.Bottom := 8;
  ScrollBoxMsg.Align := alClient;
  ScrollBoxMsg.HorzScrollBar.Visible := False;
  ScrollBoxMsg.VertScrollBar.Smooth := True;
  ScrollBoxMsg.VertScrollBar.Style := ssHotTrack;
  ScrollBoxMsg.VertScrollBar.Tracking := True;
  ScrollBoxMsg.Font.Name := 'Lucida Sans Typewriter';
  ScrollBoxMsg.Font.Size := 10;
// ScrollBoxMsg.Font.Style := [fsBold];
  ScrollBoxMsg.OnMouseWheelDown := CustomScrollBoxMouseWheelDown;
  ScrollBoxMsg.OnMouseWheelUp := CustomScrollBoxMouseWheelUp;
 
  // label message
  LabelMessage := TResizableLabel.Create(Self);
  LabelMessage.Name := 'LabelMessage';
  LabelMessage.Parent := ScrollBoxMsg;
  LabelMessage.ParentFont := True;
  LabelMessage.Top := 0;
  LabelMessage.Left := 0;
  LabelMessage.Layout := tlTop;
  LabelMessage.Transparent := True;
  LabelMessage.AlignWithMargins := True;
  LabelMessage.AutoSize := True;
end;
 
function DoGetDlgIcon(ADialogType: TMsgDlgType): HICON;
const
  IconIDs: array [TMsgDlgType] of PWideChar = (IDI_EXCLAMATION, IDI_ERROR, IDI_INFORMATION, IDI_QUESTION, IDI_APPLICATION);
var
  IconID: PWideChar;
begin
  IconID := IconIDs[ADialogType];
  Result := LoadIcon(0, IconID);
end;
 
function DoTaskBarBounds: TRect;
begin
  GetWindowRect(FindWindow('Shell_TrayWnd', nil), Result);
end;
 
function DoTaskBarPosition: TAlign;
var
  LTaskBarBounds: TRect;
  LScrW, LScrH  : Integer;
begin
  LScrW := Screen.Width;
  LScrH := Screen.Height;
  LTaskBarBounds := DoTaskBarBounds;
  if (LTaskBarBounds.Top > LScrH div 2) and (LTaskBarBounds.Right >= LScrW) then
    Result := alBottom
  else
    if (LTaskBarBounds.Top < LScrH div 2) and (LTaskBarBounds.Bottom <= LScrW div 2) then
      Result := alTop
    else
      if (LTaskBarBounds.Left < LScrW div 2) and (LTaskBarBounds.Top <= 0) then
        Result := alLeft
      else
        Result := alRight;
end;
 
function DoTaskBarWidth: Integer;
begin
  with DoTaskBarBounds do
    Result := Right - Left;
end;
 
function DoTaskBarHeight: Integer;
begin
  with DoTaskBarBounds do
    Result := Bottom - Top;
end;
 
{ TWaitForm }
 
procedure TWaitForm.CustomAppEventsModalBegin(Sender: TObject);
begin
  MsgDlgInstance.CloseWaitMessage;
end;
 
procedure DisableProcessWindowsGhosting;
var
  LUser32: HMODULE;
  LProc  : TProcedure;
begin
  LUser32 := GetModuleHandle('USER32');
  if LUser32 <> 0 then
  begin
    LProc := GetProcAddress(LUser32, 'DisableProcessWindowsGhosting');
    if Assigned(LProc) then
      LProc;
  end;
end;
 
procedure EmptyKeyQueue;
var
  LMessage: TMsg;
begin
  while PeekMessage(LMessage, 0, $0100, $0109, 1 or 2) do
      ;
end;
 
procedure EmptyMouseQueue;
var
  LMessage: TMsg;
begin
  while PeekMessage(LMessage, 0, $0200, $020E, 1 or 2) do
      ;
end;
 
var
  WaitForm      : TForm;
  LastActiveForm: TForm;
  WindowList    : TTaskWindowList;
  WindowLocked  : Boolean;
 
const
  MinHeight = 120;
  MinWidth  = 450;
 
function CreateWaitDlg(const AMessage: string): TForm;
const
  FWhiteColor = 16777215;
  FFontTahoma = 'Tahoma';
 
var
  FPanelLeft, FPanelTop: Integer;
begin
  if not Assigned(LastActiveForm) then
    if Assigned(Screen.ActiveForm) then
      if not(Screen.ActiveForm.ClassNameIs(TWaitForm.ClassName)) then
      begin
        LastActiveForm := Screen.ActiveForm;
        if Assigned(LastActiveForm) then
          WindowLocked := LockWindowUpdate(LastActiveForm.Handle);
      end;
  Result := TWaitForm.CreateNew(LastActiveForm);
  with Result do
  begin
    Name := 'WaitForm';
    BorderIcons := [];
    BorderStyle := bsNone;
    DoubleBuffered := False;
    Color := clFuchsia;
    Tag := -99;
    PopupMode := pmAuto;
    Position := poOwnerFormCenter;
    Caption := Application.Title;
    // dimensões padrao
    ClientHeight := MinHeight;
    ClientWidth := MinWidth;
    // dimensiona de acordo ao formulario ativo
    if Assigned(LastActiveForm) then
    begin
      ClientHeight := LastActiveForm.Height;
      ClientWidth := LastActiveForm.Width;
    end;
    // posição do panel
    FPanelLeft := 0;
    FPanelTop := (ClientHeight div 2) - (MinHeight div 2);
    // tratamento de transparência
    TransparentColorValue := Color;
    TransparentColor := True;
    AlphaBlendValue := 240;
    AlphaBlend := True;
  end;
 
  // panel
  TWaitForm(Result).PanelContainer := TPanel.Create(Result);
  with TWaitForm(Result).PanelContainer do
  begin
    Parent := Result;
    Color := $00804000; // $0068001F;
    ParentBackground := False;
    if Assigned(LastActiveForm) then
      BevelKind := bkNone
    else
      BevelKind := bkFlat;
    SetBounds(FPanelLeft, FPanelTop, TWaitForm(Result).ClientWidth, MinHeight);
  end;
 
  // label version
  with TLabel.Create(Result) do
  begin
    Parent := TWaitForm(Result).PanelContainer;
    Transparent := True;
    Caption := DoGetExeVersion;
    ParentFont := False;
    Layout := tlCenter;
    Font.Color := FWhiteColor;
    Font.Name := FFontTahoma;
    Font.Size := 7;
    Left := 8;
    Top := 5;
  end;
 
  // label aguarde
  with TLabel.Create(Result) do
  begin
    Parent := TWaitForm(Result).PanelContainer;
    AlignWithMargins := True;
    Align := alTop;
    Margins.Top := 15;
    Alignment := taCenter;
    Transparent := True;
    Caption := 'Aguarde';
    ParentFont := False;
    Layout := tlCenter;
    Font.Color := FWhiteColor;
    Font.Name := FFontTahoma;
    Font.Size := 18;
    Font.Style := [fsBold];
  end;
 
  // label msg
  TWaitForm(Result).LabelMessage := TLabel.Create(Result);
  with TWaitForm(Result).LabelMessage do
  begin
    Parent := TWaitForm(Result).PanelContainer;
    AlignWithMargins := True;
    Align := alClient;
    Alignment := taCenter;
    Transparent := True;
    Caption := 'Processando ...';
    ParentFont := False;
    Layout := tlCenter;
    WordWrap := True;
    Font.Color := FWhiteColor;
    Font.Name := FFontTahoma;
    Font.Size := 12;
    Font.Style := [fsBold];
  end;
 
  // ApplicationEvents
  with TWaitForm(Result) do
  begin
    AppEvents := TApplicationEvents.Create(Result);
    AppEvents.OnModalBegin := CustomAppEventsModalBegin;
  end;
end;
 
{ TDialogMessage }
 
var
  FDialogMessageInstance: TDialogMessage = nil;
  FDialogMessageCanFree : Boolean        = False;
 
class function TDialogMessage.ConfirmMessage(const AMessage: string; AWarningIcon: Boolean): Boolean;
var
  LMsgType : TMsgDlgType;
  LMsgSound: Cardinal;
begin
  LMsgType := mtConfirmation;
  LMsgSound := 32;
  if AWarningIcon then
  begin
    LMsgType := mtWarning;
    LMsgSound := 48;
  end;
  MessageBeep(LMsgSound);
  Result := Self.ShowMessageDialog(AMessage, LMsgType, ['&Sim', '&Não', 'Cancela'], -1, 3) = 1;
end;
 
class function TDialogMessage.ConfirmMessage(const AMessage: string): Boolean;
begin
  Result := Self.ConfirmMessage(AMessage, False);
end;
 
constructor TDialogMessage.Create;
begin
  raise Exception.Create('O método "Create" da classe não pode ser usado, utilize "GetInstance".');
end;
 
procedure TDialogMessage.FreeInstance;
begin
  if FDialogMessageCanFree then
    inherited;
end;
 
class function TDialogMessage.GetInstance: TDialogMessage;
begin
  Result := (Self.NewInstance as TDialogMessage);
end;
 
class procedure TDialogMessage.InternalFree;
begin
  if Assigned(FDialogMessageInstance) then
  begin
    FDialogMessageCanFree := True;
    FDialogMessageInstance.Free;
  end;
end;
 
class function TDialogMessage.NewInstance: TObject;
begin
  if not(Assigned(FDialogMessageInstance)) then
  begin
    FDialogMessageInstance := TDialogMessage(inherited NewInstance);
    FDialogMessageCanFree := False;
  end;
  Result := FDialogMessageInstance;
end;
 
function CreateCustomMessageDialog(
  const AMessage: string;
  const ADialogType: TMsgDlgType;
  const AButtons: array of string;
  const ADefaultIndex, ACancelIndex: Integer;
  const AButtonWidth: Integer = 75;
  const AButtonHeight: Integer = 25): TForm;
var
  I             : Integer;
  LButtonsLeft  : Integer;
  LButtonsWidth : Integer;
  LIconTextWidth: Integer;
  LLabelWidth   : Integer;
  LScreenWidth  : Integer;
  LScreenHeight : Integer;
  LClientWidth  : Integer;
begin
  Result := TMessageDialog.CreateNew(Application);
  with TMessageDialog(Result) do
  begin
    ExeVersion := DoGetExeVersion;
    ImageIcon.Picture.Icon.Handle := DoGetDlgIcon(ADialogType);
    PanelButtons.Height := AButtonHeight + 16;
    DoCenterControl(LabelCopy, True, False);
    LabelMessage.Caption := AMessage;
    LIconTextWidth := Max(ImageIcon.ClientWidth + LabelMessage.ClientWidth + 16, 250);
    LLabelWidth := LabelCopy.ClientWidth + 10;
    LButtonsWidth := LLabelWidth;
    SetLength(ButtonArray, Length(AButtons));
    for I := Low(AButtons) to High(AButtons) do
    begin
      ButtonArray[I] := TButton.Create(Result);
      ButtonArray[I].Parent := PanelButtons;
      ButtonArray[I].Font.Style := [];
      if I = Pred(ADefaultIndex) then
      begin
        ButtonArray[I].Default := True;
        ActiveControl := ButtonArray[I];
      end;
      ButtonArray[I].Cancel := I = Pred(ACancelIndex);
      ButtonArray[I].Tag := I + 1;
      ButtonArray[I].Caption := AButtons[I];
      ButtonArray[I].OnClick := ButtonClick;
      ButtonArray[I].Height := AButtonHeight;
      ButtonArray[I].Width := Max(AButtonWidth, Canvas.TextWidth(AButtons[I]) + 20);
      LButtonsWidth := LButtonsWidth + ButtonArray[I].Width + 4;
      ButtonArray[I].Top := 8;
    end;
    LScreenWidth := Screen.WorkAreaWidth;
    LScreenHeight := Screen.WorkAreaHeight;
    case DoTaskBarPosition of
      alTop, alBottom:
        LScreenHeight := LScreenHeight - DoTaskBarHeight;
      alLeft, alRight:
        LScreenWidth := LScreenWidth - DoTaskBarWidth;
    end;
 
    LClientWidth := Min(Max(LButtonsWidth, LIconTextWidth) + 32, (LScreenWidth - 64));
 
    if LabelMessage.ClientWidth > LClientWidth then
    begin
      LabelMessage.Constraints.MaxWidth := LClientWidth - 80;
      LabelMessage.WordWrap := True;
    end
    else
    begin
      // LabelMessage.AutoSize := False;
      LabelMessage.Align := alClient;
      LabelMessage.Layout := tlCenter;
    end;
 
    ClientWidth := LClientWidth;
 
    ClientHeight := Min(
      Max(PanelCaption.Height +
          PanelButtons.Height +
          LabelMessage.Height + 32,
 
        PanelCaption.Height +
          PanelButtons.Height +
          ImageIcon.Height) + 32,
 
      (LScreenHeight - 32)
      );
 
    LButtonsLeft := LLabelWidth + ((ClientWidth - LButtonsWidth) div 2);
    for I := Low(ButtonArray) to High(ButtonArray) do
    begin
      ButtonArray[I].Left := LButtonsLeft;
      LButtonsLeft := LButtonsLeft + ButtonArray[I].Width + 6;
    end;
  end;
end;
 
class function TDialogMessage.ShowCustomMessageDialog(
  const AMessage, ATitle: string;
  const ADialogType: TMsgDlgType;
  const AButtons: array of string;
  const ADefaultIndex, ACancelIndex, AHelpIndex, AHelpContext: Integer;
  const AHelpFileName: string;
  const APositionX, APositionY: Integer): Integer;
var
  LDialog: TMessageDialog;
  LTitle : string;
begin
  LDialog := TMessageDialog(CreateCustomMessageDialog(AMessage, ADialogType, AButtons, ADefaultIndex, ACancelIndex));
  try
    LTitle := ATitle.Trim;
    if LTitle.IsEmpty then
      LTitle := Application.Title.Trim;
    LDialog.PanelCaption.Caption := LTitle.Trim;
    if not(LDialog.ExeVersion.Trim.IsEmpty) and not(LTitle.IsEmpty) then
      LTitle := LDialog.ExeVersion + ' - ' + LTitle.Trim;
    LDialog.Caption := LTitle;
    LDialog.HelpFile := AHelpFileName;
    if AHelpIndex in [Low(AButtons) .. High(AButtons)] then
    begin
      LDialog.ButtonArray[AHelpIndex].HelpContext := AHelpContext;
      LDialog.ButtonArray[AHelpIndex].Tag := 0;
    end;
    if APositionX >= 0 then
      LDialog.Left := APositionX;
    if APositionY >= 0 then
      LDialog.Top := APositionY;
    if (APositionY < 0) and (APositionX < 0) then
      LDialog.Position := poOwnerFormCenter;
    Application.NormalizeAllTopMosts;
    Application.RestoreTopMosts;
    Application.BringToFront;
    Result := LDialog.ShowModal;
  finally
    LDialog.Free;
  end;
end;
 
class function TDialogMessage.ShowCustomMessageDialogPos(
  const AMessage, ATitle: string;
  const ADialogType: TMsgDlgType;
  const AButtons: array of string;
  const ADefaultIndex, ACancelIndex, APositionX, APositionY: Integer): Integer;
begin
  Result := Self.ShowCustomMessageDialog(AMessage, ATitle, ADialogType, AButtons, ADefaultIndex, ACancelIndex, -1, 0, '', APositionX, APositionY);
end;
 
class procedure TDialogMessage.ShowErrorMessage(AErrorMessage: string);
begin
  if AErrorMEssage.Trim.IsEmpty then
    AErrorMessage := 'Error Message';
  Self.ShowCustomMessageDialogPos(AErrorMessage.Trim, Application.Title, mtError, ['&Ok'], 0, -1, -1, -1);
end;
 
class procedure TDialogMessage.ShowExceptionDialog(AErrorMessage: string);
begin
  Self.ShowErrorMessage(AErrorMessage);
  Abort;
end;
 
class procedure TDialogMessage.ShowExceptionDialog(AException: Exception);
begin
  Self.ShowExceptionDialog(AException.Message);
end;
 
class procedure TDialogMessage.ShowMessageDialog(const AMessage, ATitle: string);
begin
  Self.ShowMessageDialog(AMessage, ATitle, mtInformation, ['&Ok']);
end;
 
class procedure TDialogMessage.ShowMessageDialog(const AMessage: string);
begin
  Self.ShowMessageDialog(AMessage, Application.Title);
end;
 
class function TDialogMessage.ShowWaitMessage(const AMessage: string): TDialogMessage;
begin
  Result := Self.GetInstance;
  if not Assigned(WaitForm) then
  begin
    WaitForm := CreateWaitDlg(AMessage);
    WindowList := DisableTaskWindows(0);
    Screen.FocusedForm := WaitForm;
    WaitForm.Show;
    SendMessage(WaitForm.Handle, CM_ACTIVATE, 0, 0);
    Screen.Cursor := crHourGlass;
  end;
 
  with TWaitForm(WaitForm) do
  begin
    if AMessage.Trim.IsEmpty then
      LabelMessage.Caption := 'Processando ...'
    else
      LabelMessage.Caption := AMessage.Trim;
  end;
  UpdateWindow(WaitForm.Handle);
end;
 
class function TDialogMessage.ShowWaitMessage(const AMessage: string; AProc: TProc): TDialogMessage;
begin
  Result := Self.GetInstance;
  Self.ShowWaitMessage(AMessage);
  try
    if Assigned(AProc) then
      AProc;
  finally
    Self.CloseWaitMessage;
  end;
end;
 
class function TDialogMessage.ShowWaitMessage(const AMessage: string; AFunc: TFunc<Boolean>): TDialogMessage;
begin
  Result := Self.GetInstance;
  Self.ShowWaitMessage(AMessage);
  try
    if Assigned(AFunc) then
      AFunc;
  finally
    Self.CloseWaitMessage;
  end;
end;
 
class function TDialogMessage.CloseWaitMessage: TDialogMessage;
begin
  Result := MsgDlgInstance;
  try
    if Assigned(WaitForm) then
    begin
      try
        if WindowList <> nil then
          EnableTaskWindows(WindowList);
        WaitForm.Tag := -1;
        WaitForm.Close;
        FreeAndNil(WaitForm);
      finally
        EmptyKeyQueue;
        EmptyMouseQueue;
        if Assigned(LastActiveForm) then
          Screen.FocusedForm := LastActiveForm;
        LastActiveForm := nil;
        WindowList := nil;
        Screen.Cursor := crDefault;
      end;
    end;
  finally
    if WindowLocked then
    begin
      LockWindowUpdate(0);
      WindowLocked := False;
    end;
  end;
end;
 
class function TDialogMessage.ShowMessageDialog(
  const AMessage, ATitle: string;
  const ADialogType: TMsgDlgType;
  const AButtons: array of string;
  const ADefaultIndex,
  ACancelIndex: Integer): Integer;
begin
  Result := Self.ShowCustomMessageDialogPos(AMessage, ATitle, ADialogType, AButtons, ADefaultIndex, ACancelIndex, -1, -1);
end;
 
class function TDialogMessage.ShowMessageDialog(
  const AMessage: string;
  const ADialogType: TMsgDlgType;
  const AButtons: array of string;
  const ADefaultIndex,
  ACancelIndex: Integer): Integer;
begin
  Result := Self.ShowMessageDialog(AMessage, '', ADialogType, AButtons, ADefaultIndex, ACancelIndex);
end;
 
class function TDialogMessage.ShowMessageDialog(
  const AMessage, ATitle: string;
  const ADialogType: TMsgDlgType;
  const AButtons: array of string): Integer;
begin
  Result := Self.ShowMessageDialog(AMessage, ATitle, ADialogType, AButtons, 0, -1);
end;
 
class function TDialogMessage.ShowMessageDialog(
  const AMessage: string;
  const ADialogType: TMsgDlgType;
  const AButtons: array of string): Integer;
begin
  Result := Self.ShowMessageDialog(AMessage, '', ADialogType, AButtons, 0, -1);
end;
 
 
 
function ShowMessageDialog(const AMessage, ATitle: string; const ADialogType: TMsgDlgType; const AButtons: array of string; const ADefaultIndex, ACancelIndex: Integer): Integer; overload;
begin
  Result := DialogMessage.ShowMessageDialog(AMessage, ADialogType, AButtons, ADefaultIndex, ACancelIndex);
end;
 
function ShowMessageDialog(const AMessage: string; const ADialogType: TMsgDlgType; const AButtons: array of string; const ADefaultIndex, ACancelIndex: Integer): Integer; overload;
begin
  Result := DialogMessage.ShowMessageDialog(AMessage, ADialogType, AButtons, ADefaultIndex, ACancelIndex);
end;
 
function ShowMessageDialog(const AMessage, ATitle: string; const ADialogType: TMsgDlgType; const AButtons: array of string): Integer; overload;
begin
  Result := DialogMessage.ShowMessageDialog(AMessage, ATitle, ADialogType, AButtons);
end;
 
function ShowMessageDialog(const AMessage: string; const ADialogType: TMsgDlgType; const AButtons: array of string): Integer; overload;
begin
  Result := DialogMessage.ShowMessageDialog(AMessage, ADialogType, AButtons);
end;
 
procedure ShowMessageDialog(const AMessage, ATitle: string); overload;
begin
  DialogMessage.ShowMessageDialog(AMessage, ATitle);
end;
 
procedure ShowMessageDialog(const AMessage: string); overload;
begin
  DialogMessage.ShowMessageDialog(AMessage);
end;
 
function ConfirmMessage(const AMessage: string; AWarningIcon: Boolean): Boolean; overload;
begin
  Result := DialogMessage.ConfirmMessage(AMessage, AWarningIcon);
end;
 
function ConfirmMessage(const AMessage: string): Boolean; overload;
begin
  Result := DialogMessage.ConfirmMessage(AMessage);
end;
 
procedure ShowErrorMessage(AErrorMessage: string); overload;
begin
  DialogMessage.ShowErrorMessage(AErrorMessage);
end;
 
procedure ShowExceptionDialog(AErrorMessage: string); overload;
begin
  DialogMessage.ShowExceptionDialog(AErrorMessage);
end;
 
procedure ShowExceptionDialog(AException: Exception); overload;
begin
  DialogMessage.ShowExceptionDialog(AException);
end;
 
function ShowWaitMessage(const AMessage: string = ''): TDialogMessage; overload;
begin
  Result := DialogMessage.ShowWaitMessage(AMessage);
end;
 
function ShowWaitMessage(const AMessage: string; AProc: TProc): TDialogMessage; overload;
begin
  Result := DialogMessage.ShowWaitMessage(AMessage, AProc);
end;
 
function ShowWaitMessage(const AMessage: string; AFunc: TFunc<Boolean>): TDialogMessage; overload;
begin
  Result := DialogMessage.ShowWaitMessage(AMessage, AFunc);
end;
 
function CloseWaitMessage: TDialogMessage;
begin
  Result := DialogMessage.CloseWaitMessage;
end;
 
initialization
 
MsgDlgInstance;
DisableProcessWindowsGhosting;
 
finalization
 
MsgDlgInstance.InternalFree;
 
end.

// mensagem de pergunta simples, com parâmetro para exibir ou nao´ícone de atenção
  if TDialogMessage.ConfirmMessage('Mensagem de pergunta', True ) then
 
 
  // mensagem personalizada, com várias versões overloads
  if TDialogMessage.ShowMessageDialog(
    'Mensagem a ser exibida',
    'Título da janela',
    mtInformation, // [mtWarning, mtError, mtInformation, mtConfirmation, mtCustom]
    ['Caption do botão 1', 'Caption do botão 2', 'Caption do botão N'] // array de strings que será criado um botão para cada caption passado
    1, // índice do botão que deve ser o Default (quando clicado ENTER) - começa em 1 e não em zero
    1 // índice do botão acionado quando clicado no ESC - começa em 1 e não em zero
    ) = 1 /*retorno do índice do botão clicado -  começa em 1 e não em zero*/ then
 
 
  // mensagem de aguarde, cria uma tela bloqueando tudo o que for digitado e clicado
  with TDialogMessage do
  begin
    ShowWaitMessage('Mensagem de aguarde ...');
    try
      // seu código demorado
    finally
      // sempre que usar essa versão (sem método anônimo), deve chamar o closeWaitMessage
      // senão a tela de aguarde apenas fechará se outro formulário for chamado com ShowModal
      CloseWaitMessage;
    end;
  end;
 
 
  TDialogMessage.ShowWaitMessage('Aguarde ...',
  procedure
  begin
    // seu código demorado
    // aqui não precisa chamar o CloseWaitMessage, pois o método quando terminado já fechará a tela
  end);
 
 
  // mensagem de erro, que aborta o código após ela, caso exista
  TDialogMessage.ShowExceptionDialog('Mensagem de erro.');
 
  // pode tmb passar uma excepton como parametro
  ....
  except
    on E: Exception do
      TDialogMessage.ShowExceptionDialog(E);
  end;