Comment faire MessageDlg centrée sur le propriétaire du formulaire

Vous pouvez faire

function MessageDlg(const AOwner: TForm; const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Integer = 0): Integer;
begin
  with CreateMessageDialog(Msg, DlgType, Buttons) do
    try
      Left := AOwner.Left + (AOwner.Width - Width) div 2;
      Top := AOwner.Top + (AOwner.Height - Height) div 2;
      Result := ShowModal;
    finally
      Free;
    end
end;

et de l'appeler comme

procedure TForm1.FormClick(Sender: TObject);
begin
  MessageDlg(Self, 'This is a test', mtInformation, [mbOK]);
end;

Cependant, personnellement, je ne pas le faire, parce que la boîte de dialogue affichée par CreateMessageDialog n'est pas natif de dialogue de Windows. Comparer le résultat visuel avec le natif de trucs:

procedure TForm1.FormClick(Sender: TObject);
begin
  case MessageBox(Handle, PChar('This is a test. Do you wish to do something?'), PChar('A Silly Example'), MB_ICONQUESTION or MB_YESNO) of
    ID_YES:
      MessageBox(Handle, PChar('Great!'), PChar('A Silly Example'), MB_ICONINFORMATION or MB_OK);
    ID_NO:
      MessageBox(Handle, PChar('OK, well, I cannot force you...'), PChar('A Silly Example'), MB_ICONINFORMATION or MB_OK);
  end;
end;

Au moins dans Windows 7 avec le thème Aero activé, le natif de dialogue ressemble beaucoup mieux. Cependant, il semble, cela ne peut pas être centré sur une forme particulière. Au lieu de cela, le dialogue est centré sur le moniteur en cours. Mais c'est aussi le comportement par défaut dans Windows (essayez le bloc-notes, WordPad, ou de la Peinture), alors pourquoi avez-vous besoin de ce nouveau comportement?

Pourquoi limiter ce désir de boîtes de dialogue de message? Comme David Heffernan commenté:

Natif dialogues toujours gagner!

Avec l'appareil(s), vous pouvez centrer tout dialogue native, comme: MessageBox, TFindDialog, TOpenDialog, TFontDialog, TPrinterSetupDialog, etc... L'unité principale dispose de deux routines, à la fois avec quelques paramètres optionnels:

function ExecuteCentered(Dialog: TCommonDialog;
  WindowToCenterIn: HWND = 0): Boolean;
function MsgBox(const Text: String; Flags: Cardinal = DefFlags;
  const Caption: String = DefCaption;
  WindowToCenterIn: HWND = 0): Integer;

Wherelse vous utilisez OpenDialog1.Execute et permettre à Windows de décider où pour afficher la boîte de dialogue, vous pouvez désormais utiliser ExecuteCentered(OpenDialog1) et le dialogue est centré sur l'écran de la forme active:

Pour afficher les boîtes de dialogue de message, utilisez MsgBox, un wrapper autour de Application.MessageBox (qui est un wrapper autour de Windows.MessageBox). Quelques exemples:

• MsgBox('Hello world!');
• MsgBox('Cancel saving?', MB_YESNO or MB_ICONQUESTION or MB_DEFBUTTON2);
• MsgBox('Please try again.', MB_OK, 'Error');
• MsgBox('I''m centered in the toolbar.', MB_OK, 'Fun!', Toolbar1.Handle);

Les unités:

unit AwDialogs;
interface
uses
Dialogs, Forms, Windows, Controls, Messages, AwHookInstance, Math, MultiMon;
const
DefCaption = 'Application.Title';
DefFlags = MB_OK;
procedure CenterWindow(WindowToStay, WindowToCenter: HWND);
function GetTopWindow: HWND;
function ExecuteCentered(Dialog: TCommonDialog;
WindowToCenterIn: HWND = 0): Boolean;
function MsgBox(const Text: String; Flags: Cardinal = DefFlags;
const Caption: String = DefCaption;
WindowToCenterIn: HWND = 0): Integer;
implementation
procedure CenterWindow(WindowToStay, WindowToCenter: HWND);
var
R1: TRect;
R2: TRect;
Monitor: HMonitor;
MonInfo: TMonitorInfo;
MonRect: TRect;
X: Integer;
Y: Integer;
begin
GetWindowRect(WindowToStay, R1);
GetWindowRect(WindowToCenter, R2);
Monitor := MonitorFromWindow(WindowToStay, MONITOR_DEFAULTTONEAREST);
MonInfo.cbSize := SizeOf(MonInfo);
GetMonitorInfo(Monitor, @MonInfo);
MonRect := MonInfo.rcWork;
with R1 do
begin
X := (Right - Left - R2.Right + R2.Left) div 2 + Left;
Y := (Bottom - Top - R2.Bottom + R2.Top) div 2 + Top;
end;
X := Max(MonRect.Left, Min(X, MonRect.Right - R2.Right + R2.Left));
Y := Max(MonRect.Top, Min(Y, MonRect.Bottom - R2.Bottom + R2.Top));
SetWindowPos(WindowToCenter, 0, X, Y, 0, 0, SWP_NOACTIVATE or
SWP_NOOWNERZORDER or SWP_NOSIZE or SWP_NOZORDER);
end;
function GetTopWindow: HWND;
begin
Result := GetLastActivePopup(Application.Handle);
if (Result = Application.Handle) or not IsWindowVisible(Result) then
Result := Screen.ActiveCustomForm.Handle;
end;
{ TAwCommonDialog }
type
TAwCommonDialog = class(TObject)
private
FCenterWnd: HWND;
FDialog: TCommonDialog;
FHookProc: TFarProc;
FWndHook: HHOOK;
procedure HookProc(var Message: THookMessage);
function Execute: Boolean;
end;
function TAwCommonDialog.Execute: Boolean;
begin
try
Application.NormalizeAllTopMosts;
FHookProc := MakeHookInstance(HookProc);
FWndHook := SetWindowsHookEx(WH_CALLWNDPROCRET, FHookProc, 0,
GetCurrentThreadID);
Result := FDialog.Execute;
finally
if FWndHook <> 0 then
UnhookWindowsHookEx(FWndHook);
if FHookProc <> nil then
FreeHookInstance(FHookProc);
Application.RestoreTopMosts;
end;
end;
procedure TAwCommonDialog.HookProc(var Message: THookMessage);
var
Data: PCWPRetStruct;
Parent: HWND;
begin
with Message do
if nCode < 0 then
Result := CallNextHookEx(FWndHook, nCode, wParam, lParam)
else
Result := 0;
if Message.nCode = HC_ACTION then
begin
Data := PCWPRetStruct(Message.lParam);
if (FDialog.Handle <> 0) and (Data.message = WM_SHOWWINDOW) then
begin
Parent := GetWindowLong(FDialog.Handle, GWL_HWNDPARENT);
if ((Data.hwnd = FDialog.Handle) and (Parent = Application.Handle)) or
((Data.hwnd = FDialog.Handle) and (FDialog is TFindDialog)) or
(Data.hwnd = Parent) then
begin
CenterWindow(FCenterWnd, Data.hwnd);
SetWindowPos(Data.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);
UnhookWindowsHookEx(FWndHook);
FWndHook := 0;
FreeHookInstance(FHookProc);
FHookProc := nil;
end;
end;
end;
end;
function ExecuteCentered(Dialog: TCommonDialog;
WindowToCenterIn: HWND = 0): Boolean;
begin
with TAwCommonDialog.Create do
try
if WindowToCenterIn = 0 then
FCenterWnd := GetTopWindow
else
FCenterWnd := WindowToCenterIn;
FDialog := Dialog;
Result := Execute;
finally
Free;
end;
end;
{ TAwMessageBox }
type
TAwMessageBox = class(TObject)
private
FCaption: String;
FCenterWnd: HWND;
FFlags: Cardinal;
FHookProc: TFarProc;
FText: String;
FWndHook: HHOOK;
function Execute: Integer;
procedure HookProc(var Message: THookMessage);
end;
function TAwMessageBox.Execute: Integer;
begin
try
try
Application.NormalizeAllTopMosts;
FHookProc := MakeHookInstance(HookProc);
FWndHook := SetWindowsHookEx(WH_CALLWNDPROCRET, FHookProc, 0,
GetCurrentThreadID);
Result := Application.MessageBox(PChar(FText), PChar(FCaption), FFlags);
finally
if FWndHook <> 0 then
UnhookWindowsHookEx(FWndHook);
if FHookProc <> nil then
FreeHookInstance(FHookProc);
Application.RestoreTopMosts;
end;
except
Result := 0;
end;
end;
procedure TAwMessageBox.HookProc(var Message: THookMessage);
var
Data: PCWPRetStruct;
Title: array[0..255] of Char;
begin
with Message do
if nCode < 0 then
Result := CallNextHookEx(FWndHook, nCode, wParam, lParam)
else
Result := 0;
if Message.nCode = HC_ACTION then
begin
Data := PCWPRetStruct(Message.lParam);
if Data.message = WM_INITDIALOG then
begin
FillChar(Title, SizeOf(Title), 0);
GetWindowText(Data.hwnd, @Title, SizeOf(Title));
if String(Title) = FCaption then
begin
CenterWindow(FCenterWnd, Data.hwnd);
SetWindowPos(Data.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);
UnhookWindowsHookEx(FWndHook);
FWndHook := 0;
FreeHookInstance(FHookProc);
FHookProc := nil;
end;
end;
end;
end;
function MsgBox(const Text: String; Flags: Cardinal = DefFlags;
const Caption: String = DefCaption;
WindowToCenterIn: HWND = 0): Integer;
begin
with TAwMessageBox.Create do
try
if Caption = DefCaption then
FCaption := Application.Title
else
FCaption := Caption;
if WindowToCenterIn = 0 then
FCenterWnd := GetTopWindow
else
FCenterWnd := WindowToCenterIn;
FFlags := Flags;
FText := Text;
Result := Execute;
finally
Free;
end;
end;
end.

unit AwHookInstance;
interface
uses
Windows;
type
THookMessage = packed record
nCode: Integer;
wParam: WPARAM;
lParam: LPARAM;
Result: LRESULT;
end;
THookMethod = procedure(var Message: THookMessage) of object;
function MakeHookInstance(Method: THookMethod): Pointer;
procedure FreeHookInstance(HookInstance: Pointer);
implementation
const
InstanceCount = 313;
type
PHookInstance = ^THookInstance;
THookInstance = packed record
Code: Byte;
Offset: Integer;
case Integer of
0: (Next: PHookInstance);
1: (Method: THookMethod);
end;
PInstanceBlock = ^TInstanceBlock;
TInstanceBlock = packed record
Next: PInstanceBlock;
Code: array[1..2] of Byte;
HookProcPtr: Pointer;
Instances: array[0..InstanceCount] of THookInstance;
end;
var
InstBlockList: PInstanceBlock;
InstFreeList: PHookInstance;
function StdHookProc(nCode: Integer; wParam: WPARAM;
lParam: LPARAM): LRESULT; stdcall; assembler;
{ In    ECX = Address of method pointer }
{ Out   EAX = Result }
asm
XOR     EAX,EAX
PUSH    EAX
PUSH    LParam
PUSH    WParam
PUSH    nCode
MOV     EDX,ESP
MOV     EAX,[ECX].Longint[4]
CALL    [ECX].Pointer
ADD     ESP,12
POP     EAX
end;
function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
Result := Longint(Dest) - (Longint(Src) + 5);
end;
function MakeHookInstance(Method: THookMethod): Pointer;
const
BlockCode: array[1..2] of Byte = ($59 { POP ECX }, $E9 { JMP StdHookProc });
PageSize = 4096;
var
Block: PInstanceBlock;
Instance: PHookInstance;
begin
if InstFreeList = nil then
begin
Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
Block^.Next := InstBlockList;
Move(BlockCode, Block^.Code, SizeOf(BlockCode));
Block^.HookProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdHookProc));
Instance := @Block^.Instances;
repeat
Instance^.Code := $E8;  { CALL NEAR PTR Offset }
Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
Instance^.Next := InstFreeList;
InstFreeList := Instance;
Inc(Longint(Instance), SizeOf(THookInstance));
until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
InstBlockList := Block;
end;
Result := InstFreeList;
Instance := InstFreeList;
InstFreeList := Instance^.Next;
Instance^.Method := Method;
end;
procedure FreeHookInstance(HookInstance: Pointer);
begin
if HookInstance <> nil then
begin
PHookInstance(HookInstance)^.Next := InstFreeList;
InstFreeList := HookInstance;
end;
end;
end.

Avis juridique: Ces unités sont écrits par moi dans cette néerlandais sujet. Les versions originales sont de Mark van Renswoude, voir NLDMessageBox.