This type of functionality for a MessageBox has been requested on the Delphi newsgroups many times and there have been several solutions written. After being introduced in XP, this functionality is now available to developers using this undocumented API.
Since this function is not documented, it is not found in Windows.pas, so it has to be defined. It is identical to the MessageBox API definition except it has two more parameters, wLanguageID and dmMilliseconds.
function MessageBoxTimeOut(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutA(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutW(
hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutW';
// this const is not defined in Windows.pas
const
MB_TIMEDOUT = 32000;
Now, to call the function, it is as easy as setting the flags and making the call. There may be other results returned that I am not aware of besides the standard IDxxx return values and the MB_TIMEDOUT result defined above.
implementation
{$R *.dfm}
//interface declaration
function MessageBoxTimeOut(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutA(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutW(
hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutW';
const
MB_TIMEDOUT = 32000;
procedure TForm3.Button1Click(Sender: TObject);
var
iRet: Integer;
iFlags: Integer;
begin
iFlags := MB_OK or MB_ICONINFORMATION;
MessageBoxTimeout(Application.Handle, 'Test a timeout of 2 seconds. ', 'MessageBoxTimeout Test', iFlags, 0, 2000) ;
iFlags := MB_YESNO or MB_ICONINFORMATION;
iRet := MessageBoxTimeout(Application.Handle, 'Test a timeout of 5 seconds.', 'MessageBoxTimeout Test', iFlags, 0, 5000) ;
case iRet of
IDYES:
ShowMessage('Yes');
IDNO:
ShowMessage('No');
MB_TIMEDOUT:
ShowMessage('TimedOut');
end;
end;
end.
{$R *.dfm}
//interface declaration
function MessageBoxTimeOut(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutA(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutW(
hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutW';
const
MB_TIMEDOUT = 32000;
procedure TForm3.Button1Click(Sender: TObject);
var
iRet: Integer;
iFlags: Integer;
begin
iFlags := MB_OK or MB_ICONINFORMATION;
MessageBoxTimeout(Application.Handle, 'Test a timeout of 2 seconds. ', 'MessageBoxTimeout Test', iFlags, 0, 2000) ;
iFlags := MB_YESNO or MB_ICONINFORMATION;
iRet := MessageBoxTimeout(Application.Handle, 'Test a timeout of 5 seconds.', 'MessageBoxTimeout Test', iFlags, 0, 5000) ;
case iRet of
IDYES:
ShowMessage('Yes');
IDNO:
ShowMessage('No');
MB_TIMEDOUT:
ShowMessage('TimedOut');
end;
end;
end.