50分请教一个简单问题，关于MessageBox

[mastersky]

有没有这样一个简单功能的函数可以用：

就是在MessageBox的原有功能上加上一个定时器（比如30秒），对话框显示后开始数秒，如果用户没有点击对话框上面的按钮，则在数秒结束后自动点击默认按钮。

比如弹出对话框如下：

X 网络连接失败，是否自动重试？
是(Y)(30) 否（N）

如果30秒后用户没有操作，则自动点“是”

[hgluo]

没有,自己定一个吧!

[andyzhou1101]

自己做个就是了
不难的

[mastersky]

就是不想自己做啊。Delphi和Windows中有没有现成的？MessageBox只差一点点就满足了。

[dabaicai]

差的就是那么一点点，呵呵
做吧

[陈保现]

自己做个就是了

[MoveFirst]

呵呵，那你就把那一点点补上就行了。

[vincentJsp]

procedure TForm1.Button1Click(Sender: TObject);
begin
form2:=Tform2.Create(Application);
form2.ShowModal;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
ShowMessage('程序即将关闭');
form2.Close;
end;


大概可以这样写

[vincentJsp]

procedure TForm1.Button1Click(Sender: TObject);
begin
form2:=Tform2.Create(Application);
form2.ShowModal;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
ShowMessage('程序即将关闭');
form2.ModalResult:=mrOk;
end;

[GARNETT2183]

自己写吧。。。非常快的...

[mastersky]

谢谢大家。我写了一个，和大家分享下：

function GetAveCharSize(Canvas: TCanvas): TPoint;
var
I: Integer;
Buffer: array[0..51] of Char;
begin
for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;

type
TMessageForm = class(TForm)
private
Message: TLabel;
Timer:TTimer;
procedure HelpButtonClick(Sender: TObject);
protected
procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure WriteToClipBoard(Text: String);
function GetFormText: String;
public
constructor CreateNew(AOwner: TComponent); reintroduce;
end;

constructor TMessageForm.CreateNew(AOwner: TComponent);
var
NonClientMetrics: TNonClientMetrics;
begin
inherited CreateNew(AOwner);
NonClientMetrics.cbSize := sizeof(NonClientMetrics);
if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
end;

procedure TMessageForm.HelpButtonClick(Sender: TObject);
begin
Application.HelpContext(HelpContext);
end;

procedure TMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Shift = [ssCtrl]) and (Key = Word('C')) then
begin
Beep;
WriteToClipBoard(GetFormText);
end;
end;

procedure TMessageForm.WriteToClipBoard(Text: String);
var
Data: THandle;
DataPtr: Pointer;
begin
if OpenClipBoard(0) then
begin
try
Data := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, Length(Text) + 1);
try
DataPtr := GlobalLock(Data);
try
Move(PChar(Text)^, DataPtr^, Length(Text) + 1);
EmptyClipBoard;
SetClipboardData(CF_TEXT, Data);
finally
GlobalUnlock(Data);
end;
except
GlobalFree(Data);
raise;
end;
finally
CloseClipBoard;
end;
end
else
raise Exception.CreateRes(@SCannotOpenClipboard);
end;

function TMessageForm.GetFormText: String;
var
DividerLine, ButtonCaptions: string;
I: integer;
begin
DividerLine := StringOfChar('-', 27) + sLineBreak;
for I := 0 to ComponentCount - 1 do
if Components[I] is TButton then
ButtonCaptions := ButtonCaptions + TButton(Components[I]).Caption +
StringOfChar(' ', 3);
ButtonCaptions := StringReplace(ButtonCaptions,'&','', [rfReplaceAll]);
Result := Format('%s%s%s%s%s%s%s%s%s%s', [DividerLine, Caption, sLineBreak,
DividerLine, Message.Caption, sLineBreak, DividerLine, ButtonCaptions,
sLineBreak, DividerLine]);
end;

type
TMessageTimeOut = class
private
FButton:TButton;
FCaption:string;
TimeOut:Cardinal;
Current:Cardinal;
Interval:Cardinal;
public
procedure TimeGo(Sender:TObject);
property Button:TButton read FButton write FButton;
property Caption:string read FCaption write FCaption;
constructor Create(aTimeOut:Cardinal;aInterval:Cardinal);
procedure SetCaption(const First:Boolean=False);
end;

constructor TMessageTimeOut.Create(aTimeOut: Cardinal;aInterval:Cardinal);
begin
TimeOut:=aTimeOut;
Interval:=aInterval;
Current:=IfThen(aTimeOut>aInterval,aTimeOut-aInterval,0);
end;

procedure TMessageTimeOut.SetCaption(const First:Boolean=False);
begin
FButton.Caption:=Format('%s(%d)',[FCaption,IfThen(First,Current+Interval,Current) div 1000]);
end;

procedure TMessageTimeOut.TimeGo(Sender: TObject);
begin
if Current=0 then
FButton.Click
else begin
SetCaption;
Current:=IfThen(Current<Interval,0,Current-Interval);
end;
end;

[mastersky]

var
Captions: array[TMsgDlgType] of Pointer = (@SMsgDlgWarning, @SMsgDlgError,
@SMsgDlgInformation, @SMsgDlgConfirm, nil);
IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION, IDI_HAND,
IDI_ASTERISK, IDI_QUESTION, nil);
ButtonNames: array[TMsgDlgBtn] of string = (
'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll',
'YesToAll', 'Help');
ButtonCaptions: array[TMsgDlgBtn] of string = (
'是(&Y)', '否(&N)', '确定(&O)', '取消(&C)', '中止(&B)', '重试(&R)', '忽略(&I)', '全部(&A)', '全否(&T)',
'全是(&L)', '帮助(&H)');
ModalResults: array[TMsgDlgBtn] of Integer = (
mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll,
mrYesToAll, 0);
var
ButtonWidths : array[TMsgDlgBtn] of integer; // initialized to zero

function MessageBoxTimeOut(const Msg,aTitle:string;DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons;DefaultButton:Integer;TimeOut:Cardinal=30000):Integer;
const
mcHorzMargin = 8;
mcVertMargin = 8;
mcHorzSpacing = 10;
mcVertSpacing = 10;
mcButtonWidth = 50;
mcButtonHeight = 14;
mcButtonSpacing = 4;
var
DialogUnits: TPoint;
HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth,
ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth,
IconTextWidth, IconTextHeight, X, ALeft: Integer;
B, CancelButton, BDefBtn: TMsgDlgBtn;
IconID: PChar;
TextRect: TRect;
Form:TMessageForm;
MsgTimeOut:TMessageTimeOut;
tmpBtn,defBtn:TButton;
begin
Form := TMessageForm.CreateNew(Application);
with Form do
begin
BiDiMode := Application.BiDiMode;
BorderStyle := bsDialog;
Canvas.Font := Font;
KeyPreview := True;
OnKeyDown := CustomKeyDown;
DialogUnits := GetAveCharSize(Canvas);
HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4);
VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8);
HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4);
VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8);
ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4);
for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
begin
if B in Buttons then
begin
if ButtonWidths[B] = 0 then
begin
TextRect := Rect(0,0,0,0);
Windows.DrawText( canvas.handle,
PChar(ButtonCaptions[B]), -1,
TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or
DrawTextBiDiModeFlagsReadingOnly);
with TextRect do ButtonWidths[B] := Right - Left + 8;
end;
if ButtonWidths[B] > ButtonWidth then
ButtonWidth := ButtonWidths[B];
end;
end;
ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8);
ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4);
SetRect(TextRect, 0, 0, Screen.Width div 2, 0);
DrawText(Canvas.Handle, PChar(Msg), Length(Msg)+1, TextRect,
DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or
DrawTextBiDiModeFlagsReadingOnly);
IconID := IconIDs[DlgType];
IconTextWidth := TextRect.Right;
IconTextHeight := TextRect.Bottom;
if IconID <> nil then
begin
Inc(IconTextWidth, 32 + HorzSpacing);
if IconTextHeight < 32 then IconTextHeight := 32;
end;
ButtonCount := 0;
BDefBtn:=mbYes;
for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
begin
if B in Buttons then Inc(ButtonCount);
if ButtonCount=DefaultButton then
begin
BDefBtn:=B;
DefaultButton:=-1;
end;
end;
ButtonGroupWidth := 0;
if ButtonCount <> 0 then
ButtonGroupWidth := ButtonWidth * ButtonCount +
ButtonSpacing * (ButtonCount - 1);
ClientWidth := Max(IconTextWidth, ButtonGroupWidth) + HorzMargin * 2;
ClientHeight := IconTextHeight + ButtonHeight + VertSpacing +
VertMargin * 2;
Left := (Screen.Width div 2) - (Width div 2);
Top := (Screen.Height div 2) - (Height div 2);
if aTitle='' then
begin
if DlgType <> mtCustom then
Caption := LoadResString(Captions[DlgType]) else
Caption := Application.Title;
end
else Caption:=aTitle;
if IconID <> nil then
with TImage.Create(Form) do
begin
Name := 'Image';
Parent := Form;
Picture.Icon.Handle := LoadIcon(0, IconID);
SetBounds(HorzMargin, VertMargin, 32, 32);
end;
Message := TLabel.Create(Form);
with Message do
begin
Name := 'Message';
Parent := Form;
WordWrap := True;
Caption := Msg;
BoundsRect := TextRect;
BiDiMode := Form.BiDiMode;
ALeft := IconTextWidth - TextRect.Right + HorzMargin;
if UseRightToLeftAlignment then
ALeft := Form.ClientWidth - ALeft - Width;
SetBounds(ALeft, VertMargin,
TextRect.Right, TextRect.Bottom);
end;
if mbCancel in Buttons then CancelButton := mbCancel else
if mbNo in Buttons then CancelButton := mbNo else
CancelButton := mbOk;
X := (ClientWidth - ButtonGroupWidth) div 2;
defBtn:=nil;
for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
begin
if B in Buttons then
begin
tmpBtn:=TButton.Create(Form);
if B=BDefBtn then
defBtn:=tmpBtn;
with tmpBtn do
begin
Name := ButtonNames[B];
Parent := Form;
Caption := ButtonCaptions[B];
ModalResult := ModalResults[B];
if B = CancelButton then Cancel := True;
SetBounds(X, IconTextHeight + VertMargin + VertSpacing,
ButtonWidth, ButtonHeight);
Inc(X, ButtonWidth + ButtonSpacing);
if B = mbHelp then
OnClick := HelpButtonClick;
end;
end;
end;
if (TimeOut>0)and(ButtonCount>0)and (defBtn<>nil) then
begin
MsgTimeOut:=TMessageTimeOut.Create(TimeOut,1000);
MsgTimeOut.Button:=defBtn;
MsgTimeOut.Caption:=defBtn.Caption;
MsgTimeOut.SetCaption(True);
Timer:=TTimer.Create(Form);
Timer.Enabled:=False;
Timer.Interval:=MsgTimeOut.Interval;
Timer.OnTimer:=MsgTimeOut.TimeGo;
Timer.Enabled:=True;
end;
ShowModal;
Result:=ModalResult;
if Assigned(Timer) then
Timer.Free;
Free;
if Assigned(MsgTimeOut) then
FreeAndNil(MsgTimeOut);
end;
end;

[mastersky]

用法如下：
if MessageBoxTimeOut('打开串口失败，是否重试？','错误',mtError,MBYesNoCancel,2,30000)=IDYes then
MessageBoxTimeOut('重试','消息',mtInformation,[mbOK],1,5000);

[dabaicai]

太复杂了，其实可以更简单的，呵呵

[xixuemao]

看看http://quester.blog.sohu.com/1895253.html

[yzcurry]

自己做一个到计时的就行了,动一下手很快的不难

[YouTuBe]

：）

[lw549]

MessageBox跟踪进去就知道了，他调用的函数是支持时间限制的，MessageBox调用的时候给时间参数赋值为-1。
汇编代码
_MessageBoxTimeout proc hWnd, lpText, lpCaption, uType, UnKnownArg, TimeOut
invoke LoadLibrary, ADDR szUser32
.if eax == 0
ret
.endif
invoke GetProcAddress, eax, ADDR szProcName
.if eax == 0
ret
.endif
push TimeOut
push UnKnownArg
push uType
push lpCaption
push lpText
push hWnd
call eax
ret

_MessageBoxTimeout endp


地址
http://borland.mblogger.cn/lw549/posts/31261.aspx

[lxtnt]

晕倒。。。。没那么复杂吧！
HOOK 一下MESSAGEBOX就好了。

[myy]

// 保存为 MsgBoxTimeOut.pas 加到工程中即可

// wLanguageId 用 0;
// dwMilliseconds 毫秒数

unit MsgBoxTimeOut;

interface

uses Windows;

const
IDTIMEDOUT = 32000; // 超时后的返回值

function MessageBoxTimeOut(hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

function MessageBoxTimeOutA(hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

function MessageBoxTimeOutW(hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

implementation


function MessageBoxTimeOut; external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutA; external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutW; external user32 name 'MessageBoxTimeoutW';

end.