vba 显示带有超时值的消息框
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/4274103/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Display a message box with a timeout value
提问by Anonymous Type
The question comes from code like this.
问题来自这样的代码。
Set scriptshell = CreateObject("wscript.shell")
Const TIMEOUT_IN_SECS = 60
Select Case scriptshell.popup("Yes or No? leaving this window for 1 min is the same as clicking Yes.", TIMEOUT_IN_SECS, "popup window", vbYesNo + vbQuestion)
Case vbYes
Call MethodFoo
Case -1
Call MethodFoo
End Select
This is a simple way to display a message box with a timeout from VBA (or VB6).
这是一种从 VBA（或 VB6）显示带有超时的消息框的简单方法。
In Excel 2007 (apparently also happens in Internet Explorer at times) the popup window will not timeout, and instead wait for user input.
在 Excel 2007 中（显然有时也会在 Internet Explorer 中发生）弹出窗口不会超时，而是等待用户输入。
This issue is tough to debug as it only happens occasionally and I do not know the steps to reproduce the issue. I believe it to be an issue with Office modal dialogs and Excel not recognising the timeout has expired.
这个问题很难调试，因为它只是偶尔发生，我不知道重现问题的步骤。我认为这是 Office 模式对话框和 Excel 无法识别超时已过期的问题。
See http://social.technet.microsoft.com/Forums/en-US/ITCG/thread/251143a6-e4ea-4359-b821-34877ddf91fb/
请参阅http://social.technet.microsoft.com/Forums/en-US/ITCG/thread/251143a6-e4ea-4359-b821-34877ddf91fb/
The workarounds I found are:
我发现的解决方法是：
A. Use a Win32 API call
A. 使用 Win32 API 调用
Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Sub MsgBoxDelay()
Const cmsg As String = "Yes or No? leaving this window for 1 min is the same as clicking Yes."
Const cTitle As String = "popup window"
Dim retval As Long
retval = MessageBoxTimeout(FindWindow(vbNullString, Title), cmsg, cTitle, 4, 0, 60000)
If retval <> 7 Then
Call MethodFoo
End If
End Sub
B. Use a manual timer with a VBA userform that is designed to look like a messagebox. Use a global variable or similar to save any state that needs to be passed back to the calling code. Ensure that the Show method of the userform is called with the vbModeless parameter supplied.
B. 使用带有 VBA 用户窗体的手动计时器，该窗体设计为看起来像一个消息框。使用全局变量或类似变量来保存需要传递回调用代码的任何状态。确保使用提供的 vbModeless 参数调用用户窗体的 Show 方法。
C. Wrap the call to wscript.popup method in the MSHTA process which would allow the code to run out of process and avoid the modal nature of Office.
C. 在 MSHTA 进程中包装对 wscript.popup 方法的调用，这将允许代码在进程外运行并避免 Office 的模式性质。
CreateObject("WScript.Shell").Run "mshta.exe vbscript:close(CreateObject(""WScript.Shell"").Popup(""Test"",2,""Real%20Time%20Status%20Message""))"
What is the best way of A, B or C or your own answer to display a message box with a timeout value in VBA?
在 VBA 中显示带有超时值的消息框的 A、B 或 C 或您自己的答案的最佳方式是什么？
采纳答案by Anonymous Type
Going with Answer A. the Win32 solution. This meets the requirements, and is robust from testing so far.
使用答案 A. Win32 解决方案。这符合要求，并且从目前的测试来看是稳健的。
Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Sub MsgBoxDelay()
Const cmsg As String = "Yes or No? leaving this window for 1 min is the same as clicking Yes."
Const cTitle As String = "popup window"
Dim retval As Long
retval = MessageBoxTimeout(FindWindow(vbNullString, Title), cmsg, cTitle, 4, 0, 60000)
If retval <> 7 Then
Call MethodFoo
End If
End Sub
回答by Nigel Heffernan
This is a long answer, but there's a lot of ground to cover: it's also a late reply, but things have changed since some of the replies to this (and similar questions) have been posted on the stack. That sucks like a vacuum cleaner on triple-phase AC, because they were good answers when they were posted and a lot of thought went into them.
这是一个很长的答案，但有很多内容需要涵盖：这也是一个迟到的回复，但自从对此（和类似问题）的一些回复发布在堆栈上后，情况发生了变化。这就像三相交流电的真空吸尘器一样糟糕，因为它们在发布时是很好的答案，并且经过了很多思考。
The short version is: I noticed that the Script WsShell Popup solution stopped working for me in VBA a year ago, and I coded a working API timer callback for the VBA MsgBox function.
简短的版本是：我注意到一年前脚本 WsShell Popup 解决方案在 VBA 中对我不起作用，我为 VBA MsgBox 函数编写了一个有效的 API 计时器回调。
Skip straight to the code under the heading VBA code to call a Message Box with a Timeoutif you need an answer in a hurry - and I did, I have literally thousands of instances of a self-dismissing 'MsgPopup' substitute for VBA.MsgBox to redact, and the code below fits into a self-contained module.
如果您急需答案，请直接跳到VBA 代码标题下的代码，以调用带有超时的消息框- 我确实做到了，我确实有数千个自我忽略的“MsgPopup”实例替代 VBA.MsgBox编辑，下面的代码适合一个独立的模块。
However, the VBA coders here - myself included - need some explanation as to why perfectly good code no longer seems to work. And if you understand the reasons, you may be able to use the partial workaround for 'Cancel' dialogs, buried in the text.
但是，这里的 VBA 编码人员（包括我自己）需要解释一下为什么完美的代码似乎不再起作用。如果您了解原因，您也许可以使用隐藏在文本中的“取消”对话框的部分解决方法。
I noticed that the Script WsShell Popup solution stopped working for me in VBA a year ago - The 'SecondsToWait' timeout was being ignored, and the dialog just hung around like the familiar VBA.MsgBox:
我注意到脚本 WsShell Popup 解决方案一年前在 VBA 中停止对我来说有效 - 'SecondsToWait' 超时被忽略，对话框就像熟悉的 VBA.MsgBox 一样：
MsgPopup = objWShell.PopUp(Prompt, SecondsToWait, Title, Buttons)
And I think I know the reason why: you can no longer send a WM_CLOSE or WM_QUIT message to a dialog window from anywhere other than the thread which opened it. Likewise, the User32 DestroyWindow() function will not close a dialog window unless it's called by the thread that opened the dialog.
我想我知道原因：你不能再从打开它的线程以外的任何地方向对话框窗口发送 WM_CLOSE 或 WM_QUIT 消息。同样，User32 DestroyWindow() 函数不会关闭对话框窗口，除非它被打开对话框的线程调用。
Someone in Redmond doesn't like the idea of a script running in the background and sending a WM_CLOSE commands to all those essential warnings that halt your work (and, these days, making them go away permanently needs local admin privileges).
Redmond 的某个人不喜欢在后台运行脚本并向所有停止工作的重要警告发送 WM_CLOSE 命令的想法（而且，现在，让它们永久消失需要本地管理员权限）。
I can't imaginewho would write a script like that, it's a terrible idea!
我无法想象谁会写出这样的剧本，这太糟糕了！
There are consequences and collateral damage to that decision: WsScript.Popup() objects in the single-threaded VBA environment implement their 'SecondsToWait' timeout using a Timer callback, and that callback sends a WM_CLOSE message, or something like it... Which is ignored in most cases, because it's a callback thread, not the owner thread for the dialog.
该决定会带来后果和附带损害：单线程 VBA 环境中的 WsScript.Popup() 对象使用 Timer 回调实现其“SecondsToWait”超时，并且该回调发送 WM_CLOSE 消息，或类似的消息......其中在大多数情况下被忽略，因为它是一个回调线程，而不是对话框的所有者线程。
You mightget it to work on a popup with a 'CANCEL' button, and it'll become clear why that is in a minute or two.
您可能会在带有“取消”按钮的弹出窗口中使用它，并且在一两分钟内就会清楚为什么会这样。
I've tried writing a timer callback to WM_CLOSE the popup, and that failed for me, too, in most cases.
我已经尝试编写一个定时器回调来 WM_CLOSE 弹出窗口，但在大多数情况下，这对我来说也失败了。
I've tried some exotic API callbacks to mess with the VBA.MsgBox and WsShell.Popup window, and I can tell you now that that they didn't work. You can't work with what isn't there: those dialog windows are very simple and most of them don't contain any functionality, at all, except for the responses in the button clicks - Yes, No, OK, Cancel, Abort, Retry, Ignore, and Help.
我已经尝试了一些奇特的 API 回调来干扰 VBA.MsgBox 和 WsShell.Popup 窗口，现在我可以告诉你，它们不起作用。你不能使用不存在的东西：那些对话框窗口非常简单，其中大部分不包含任何功能，除了按钮点击中的响应 - 是、否、确定、取消、中止、重试、忽略和帮助。
'Cancel' is an interesting one: it appears that you get a freebie from the primitive Windows API for built-in dialogs when you specify vbOKCancelor vbRetryCancelor vbYesNoCancel- the 'Cancel' function is automatically implemented with a 'close' button in the dialog's Menu bar (you don't get that with the other buttons, but feel free to try it with a dialog containing 'Ignore'), which means that....
“取消”是一个有趣的：看来你从原始的Windows API和赠品的内置对话框，当你指定vbOKCancel或vbRetryCancel或 vbYesNoCancel- “取消”功能会自动在对话框的菜单栏中选择“关闭”按钮来实现（您无法使用其他按钮获得该功能，但您可以使用包含“忽略”的对话框随意尝试），这意味着....
WsShell.Popup() dialogs will sometimes respond to the SecondsToWait timeout if they have a 'Cancel' option.
如果 WsShell.Popup() 对话框有“取消”选项，它们有时会响应 SecondsToWait 超时。
objWShell.PopUp("Test Me", 10, "Dialog Test", vbQuestion + vbOkCancel)
That might be a good enough workaround for someone reading this, if all you wanted was to get WsShell.Popup() functions to respond to the SecondsToWait parameter again.
如果您只想让 WsShell.Popup() 函数再次响应 SecondsToWait 参数，那么对于阅读本文的人来说，这可能是一个足够好的解决方法。
This also means that you can send WM_CLOSE messages to the 'Cancel' dialog using the SendMessage() API call on a callback:
这也意味着您可以在回调中使用 SendMessage() API 调用将 WM_CLOSE 消息发送到“取消”对话框：
SendMessage(hwndDlgBox, WM_CLOSE, ByVal 0&, ByVal 0&)
Strictly speaking, this should only work for the WM_SYSCOMMAND, SC_CLOSEmessage - the 'close' box in the command bar is a 'system' menu with a special class of commands but, like I said, we're getting freebies from the Windows API.
严格来说，这应该只对WM_SYSCOMMAND, SC_CLOSE消息有效——命令栏中的“关闭”框是一个带有特殊命令类别的“系统”菜单，但正如我所说，我们从 Windows API 获得免费赠品。
I got that to work, and I started thinking: If I can only work with what's there, maybe I'd better find out what's actually there...
我让它起作用了，我开始思考：如果我只能使用那里的东西，也许我最好找出实际存在的东西......
And the answer turns out to be obvious: Dialog boxes have their own set of WM_COMMAND message parameters -
答案很明显：对话框有自己的一组 WM_COMMAND 消息参数 -
' Dialog window message parameters, replicating Enum vbMsgBoxResult:
CONST dlgOK As Long = 1
CONST dlgCANCEL As Long = 2
CONST dlgABORT As Long = 3
CONST dlgRETRY As Long = 4
CONST dlgIGNORE As Long = 5
CONST dlgYES As Long = 6
CONST dlgNO As Long = 7
And, as these are the 'user' messages which return the user responses to the caller (that is to say, the calling thread) of the dialog, the dialog box is happy to accept them and close itself.
而且，由于这些是将用户响应返回给对话框的调用者（即调用线程）的“用户”消息，因此对话框很乐意接受它们并自行关闭。
You can interrogate a dialog window to see if it implements a particular command and, if it does, you can send that command:
您可以询问对话窗口以查看它是否实现了特定命令，如果实现了，您可以发送该命令：
If GetDlgItem(hWndMsgBox, vbRetry) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, vbRetry, 0&
Exit For
End If
The remaining challenge is to detect a 'Timeout' and intercept the returning Message Box response, and substitute our own value: -1 if we're following the convention established by the WsShell.Popup()function. So our 'msgPopup' wrapper for a Message Box with a timeout needs to do three things:
剩下的挑战是检测“超时”并拦截返回的消息框响应，并替换我们自己的值：-1 如果我们遵循WsShell.Popup()函数建立的约定。所以我们的带有超时的消息框的 'msgPopup' 包装器需要做三件事：
- Call our API Timer for the delayed dismissal of the dialog;
- Open the message Box, passing in the usual parameters;
- Either: Detect a timeout and substitute the 'timeout' response...
...Or return the user response to the dialog, if they responded in time
- 调用我们的 API Timer 以延迟关闭对话框；
- 打开消息框，传入常用参数；
- 要么：检测超时并替换“超时”响应...
...或者将用户响应返回到对话框，如果他们及时响应
Elsewhere, we need to declare the API calls for all this, and we absolutely musthave a Publicly-declared 'TimerProc' function for the Timer API to call. That function has to exist, and it has to run to 'End Function' without errors or breakpoints - any interruption, and the API Timer() will call down the wrath of the operating system.
在其他地方，我们需要为所有这些声明 API 调用，并且我们绝对必须有一个公开声明的“TimerProc”函数供 Timer API 调用。该函数必须存在，并且它必须在没有错误或断点的情况下运行到“结束函数” - 任何中断，并且 API Timer() 将调用操作系统的愤怒。
VBA code to call a Message Box with a Timeout:
使用超时调用消息框的 VBA 代码：
Option Explicit
Option Private Module
' Nigel Heffernan January 2016
' Modified from code published by Microsoft on MSDN, and on StackOverflow: this code is in ' the public domain.
' This module implements a message box with a 'timeout'
' It is similar to implementations of the WsShell.Popup() that use a VB.MessageBox interface
' with an additional 'SecondsToWait' or 'Timeout' parameter.
Private m_strCaption As String
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult
' Replicates the VBA MsgBox() function, with an added parameter to automatically dismiss the message box after n seconds
' If dismissed automatically, this will return -1: NOT 'cancel', nor the default button choice.
Dim TimerStart As Single
If Title = "" Then
Title = ThisWorkbook.Name
End If
If SecondsToWait > 0 Then
' TimedmessageBox launches a callback to close the MsgBox dialog
TimedMessageBox Title, SecondsToWait
TimerStart = VBA.Timer
End If
MsgPopup = MsgBox(Prompt, Buttons, Title)
If SecondsToWait > 0 Then
' Catch the timeout, substitute -1 as the response
If (VBA.Timer - TimerStart) >= SecondsToWait Then
MsgPopup = -1
End If
End If
End Function
Public Function MsgBoxResultText(ByVal MsgBoxResult As VbMsgBoxResult) As String
' Returns a text value for the integers returned by VBA MsgBox() and WsShell.Popup() dialogs
' Additional value: 'TIMEOUT', returned when the MsgBoxResult = -1 ' All other values return the string 'ERROR'
On Error Resume Next
If (MsgBoxResult >= vbOK) And (MsgBoxResult <= vbNo) Then
MsgBoxResultText = Split("ERROR,OK,CANCEL,ABORT,RETRY,IGNORE,YES,NO,", ",")(MsgBoxResult)
ElseIf MsgBoxResult = dlgTIMEOUT Then
MsgBoxResultText = "TIMEOUT"
Else
MsgBoxResultText = "ERROR"
End If
End Function
'
'
'
'
'
'
'
'
'
'
Private Property Get MessageBox_Caption() As String
MessageBox_Caption = m_strCaption
End Property
Private Property Let MessageBox_Caption(NewCaption As String)
m_strCaption = NewCaption
End Property
Private Sub TimedMessageBox(Caption As String, Seconds As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' Public Sub TimerProcMessageBox MUST EXIST
MessageBox_Caption = Caption
SetTimer 0&, 0&, Seconds * 1000, AddressOf TimerProcMessageBox
Debug.Print "start Timer " & Now
End Sub
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows
' Use LongLong and LongPtr
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As LongLong)
On Error Resume Next
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
' Closes a dialog box (Shell.Popup or VBA.MsgBox) having a caption stored in MessageBox_Caption
' This TimerProc sends *any* message that can close the dialog: the objective is solely to close
' the dialog and resume the VBA thread. Your caller must detect the expired TimerProc interval
' and insert a custom return value (or default) that signals the 'Timeout' for responses.
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox
KillTimer hWndMsgBox, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand
End If
End Sub
#ElseIf VBA7 Then ' 64 bit Excel in all environments
' Use LongPtr only
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
' Closes a dialog box (Shell.Popup or VBA.MsgBox) having a caption stored in MessageBox_Caption
' This TimerProc sends *any* message that can close the dialog: the objective is solely to close
' the dialog and resume the VBA thread. Your caller must detect the expired TimerProc interval
' and insert a custom return value (or default) that signals the 'Timeout' for responses.
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox
Dim iDlgCommand As VbMsgBoxResult ' Dialog command values: OK, CANCEL, YES, NO, etc
KillTimer hwnd, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand
End If
End Sub
#Else ' 32 bit Excel
Public Sub TimerProcMessageBox(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As Long ' Handle to VBA MsgBox
KillTimer hwnd, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand
End If
End Sub
#End If
And here are the API declarations - note the conditional declarations for VBA7, 64-Bit Windows, and plain-vanilla 32-bit:
这里是 API 声明 - 请注意 VBA7、64 位 Windows 和普通 32 位的条件声明：
' Explanation of compiler constants for 64-Bit VBA and API declarations :
' https://msdn.microsoft.com/en-us/library/office/ee691831(v=office.14).aspx
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows ' Use LongLong and LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr _
) As Long
Public Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr _
) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" _
(ByVal hWndDlg As LongPtr, _
ByVal nIDDlgItem As Long _
) As LongPtr
#ElseIf VBA7 Then ' VBA7 in all environments, including 32-Bit Office ' Use LongPtr for ptrSafe declarations, LongLong is not available
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" _
(ByVal hWndDlg As LongPtr, _
ByVal nIDDlgItem As Long _
) As LongPtr
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As Long
Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function GetDlgItem Lib "user32" _
(ByVal hWndDlg, ByVal nIDDlgItem As Long) As Long
#End If
Private Enum WINDOW_MESSAGE
WM_ACTIVATE = 6
WM_SETFOCUS = 7
WM_KILLFOCUS = 8
WM_PAINT = &HF
WM_CLOSE = &H10
WM_QUIT = &H12
WM_COMMAND = &H111
WM_SYSCOMMAND = &H112
End Enum
' Dialog Box Command IDs - replicates vbMsgBoxResult, with the addition of 'dlgTIMEOUT'
Public Enum DIALOGBOX_COMMAND
dlgTIMEOUT = -1
dlgOK = 1
dlgCANCEL = 2
dlgABORT = 3
dlgRETRY = 4
dlgIGNORE = 5
dlgYES = 6
dlgNO = 7
End Enum
A final note: I would welcome suggestions for improvement from experienced MFC C++ developers, as you are going to have a much better grasp of the basic Windows message-passing concepts underlying a 'Dialog' window - I work in an oversimplified language and it is likely that the oversimplifications in my understanding have crossed the line into outright errors in my explanation.
最后一点：我欢迎有经验的 MFC C++ 开发人员提出改进建议，因为您将更好地掌握“对话框”窗口背后的基本 Windows 消息传递概念 - 我使用一种过于简化的语言，它是可能我理解中的过度简化已经越过了我的解释中的彻头彻尾的错误。
回答by CSmith
Starting with the samples in this post my final code is as follows:
从这篇文章中的示例开始，我的最终代码如下：
' Coded by Clint Smith
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' tMsgBox Function (Timered Message Box)
' By Clint Smith, [email protected]
' Created 04-Sep-2014
' Updated for 64-bit 03-Mar-2020
' This provides an publicly accessible procedure named
' tMsgBox that when invoked instantiates a timered
' message box. Many constants predefined for easy use.
' There is also a global result variable tMsgBoxResult.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const mbBTN_Ok = vbOKOnly 'Default
Public Const mbBTN_OkCancel = vbOKCancel
Public Const mbBTN_AbortRetryIgnore = vbAbortRetryIgnore
Public Const mbBTN_YesNoCancel = vbYesNoCancel
Public Const mbBTN_YesNo = vbYesNo
Public Const mbBTN_RetryCancel = vbRetryCancel
Public Const mbBTN_CanceTryagainContinue = &H6
Public Const mbICON_Stop = vbCritical
Public Const mbICON_Question = vbQuestion
Public Const mbICON_Exclaim = vbExclamation
Public Const mbICON_Info = vbInformation
Public Const mbBTN_2ndDefault = vbDefaultButton2
Public Const mbBTN_3rdDefault = vbDefaultButton3
Public Const mbBTN_4rdDefault = vbDefaultButton4
Public Const mbBOX_Modal = vbSystemModal
Public Const mbBTN_AddHelp = vbMsgBoxHelpButton
Public Const mbTXT_RightJustified = vbMsgBoxRight
Public Const mbWIN_Top = &H40000 'Default
Public Const mbcTimeOut = 32000
Public Const mbcOk = vbOK
Public Const mbcCancel = vbCancel
Public Const mbcAbort = vbAbort
Public Const mbcRetry = vbRetry
Public Const mbcIgnore = vbIgnore
Public Const mbcYes = vbYes
Public Const mbcNo = vbNo
Public Const mbcTryagain = 10
Public Const mbcContinue = 11
Public Const wAccessWin = "OMain"
Public Const wExcelWin = "XLMAIN"
Public Const wWordWin = "OpusApp"
Public tMsgBoxResult As Long
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function tMsgBoxA Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Declare Function tMsgBoxA Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
#End If
Public Sub tMsgBox( _
Optional sMessage As String = "Default: (10 sec timeout)" & vbLf & "Coded by Clint Smith", _
Optional sTitle As String = "Message Box with Timer", _
Optional iTimer As Integer = 10, _
Optional hNtype As Long = mbBTN_Ok + mbWIN_Top, _
Optional hLangID As Long = &H0, _
Optional wParentType As String = vbNullString, _
Optional wParentName As String = vbNullString)
tMsgBoxResult = tMsgBoxA(FindWindow(wParentType, wParentName), sMessage, sTitle, hNtype, hLangID, 1000 * iTimer)
End Sub
回答by user7522256
Easy
简单
Call CreateObject("WScript.Shell").Popup("Timed message box", 1, "Title", vbOKOnly)
回答by Matú?
Private Declare Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal MsgText As String, _
ByVal Title As String, _
ByVal MsgBoxType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal Timeout As Long) _
As Long
Dim btnOK As Boolean
Dim btnCancel As Boolean
Dim MsgTimeOut As Boolean
Option Explicit
Sub Main
AutoMsgbox("Message Text", "Title", vbOkCancel , 5) '5 sec TimeOut
MsgBox("Pressed OK: " & btnOK & vbNewLine & "Pressed Cancel: " & btnCancel & vbNewLine &"MsgBox Timeout: " & MsgTimeOut)
End Sub
Function AutoMsgbox(MsgText , Title , MsgBoxType , Timeout)
Dim ReturnValue
Dim TimeStamp As Date
TimeStamp = DateAdd("s",Timeout,Now)
Dim MsgText1 As String
Dim TimeOutCounter As Integer
For TimeOutCounter = 0 To Timeout
MsgText1 = MsgText & vbNewLine & vbNewLine & " Auto Selction in " & Timeout - TimeOutCounter & " [s]"
ReturnValue = MsgBoxTimeout(0 , MsgText1 , Title, MsgBoxType, 0 ,1000)
Select Case ReturnValue
Case 1
btnOK = True
btnCancel = False
MsgTimeOut = False
Exit Function
Case 2
btnOK = False
btnCancel = True
MsgTimeOut = False
Exit Function
Case 32000
btnOK = False
btnCancel = False
MsgTimeOut = True
End Select
Next TimeOutCounter
End Function
