问题来自这样的代码。
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
这是一种显示带有VBA（或VB6）超时的消息框的简单方法。
在Excel 2007中（显然有时也会在Internet Explorer中发生）弹出窗口不会超时，而是等待用户输入。
这个问题很难调试，因为它偶尔会发生，我不知道重现问题的步骤。我认为这是Office模式对话框和Excel无法识别超时已过期的问题。
请参阅http://social.technet.microsoft.com/Forums/en-US/ITCG/thread/251143a6-e4ea-4359-b821-34877ddf91fb/
我找到的解决方法是：
一个。使用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中。使用具有VBA用户表单的手动计时器，其设计看起来像消息框。使用全局变量或类似函数来保存需要传递回调用代码的任何状态。确保使用提供的vbModeless参数调用userform的Show方法。
℃。在MSHTA进程中包含对wscript.popup方法的调用，这将允许代码用完进程并避免Office的模式性质。
CreateObject("WScript.Shell").Run "mshta.exe vbscript:close(CreateObject(""WScript.Shell"").Popup(""Test"",2,""Real%20Time%20Status%20Message""))"
在VBA中显示带超时值的消息框时，A，B或C的最佳方式或您自己的答案是什么？
答案 0 :(得分：7)
这是一个很长的答案，但还有很多理由可以覆盖：它也是一个迟到的答案，但事情已经发生变化，因为对此（以及类似的问题）的一些回复已经发布在堆栈上。这对于三相AC上的真空吸尘器来说很糟糕，因为当它们被发布并且很多想法进入它们时它们是很好的答案。
简短版本是：我注意到一年前脚本WsShell Popup解决方案在VBA中停止了工作，我编写了一个用于VBA MsgBox函数的工作API计时器回调。
直接跳到标题 VBA代码下的代码，如果您急需一个答案，则调用带有超时的消息框 - 我做了，我确实有成千上万的自我实例-dismissing＆＃39; MsgPopup＆＃39;替换VBA.MsgBox进行编辑，下面的代码适合自包含的模块。
然而，这里的VBA编码员 - 包括我自己 - 需要一些解释，为什么完美的代码似乎不再起作用。如果您了解原因，您可以使用部分解决方法来取消＆＃39;取消＆＃39;对话，埋在文本中。
我注意到脚本WsShell Popup解决方案在一年前停止在VBA中为我工作 - ＆＃39; SecondsToWait＆＃39;正在忽略超时，对话框就像熟悉的VBA.MsgBox：
一样MsgPopup = objWShell.PopUp(Prompt, SecondsToWait, Title, Buttons)
我想我知道原因：你不能再从打开它的线程以外的任何地方向对话框窗口发送WM_CLOSE或WM_QUIT消息。同样，User32 DestroyWindow（）函数不会关闭对话窗口，除非它被打开对话框的线程调用。
Redmond中的某个人不喜欢在后台运行脚本的想法，并向所有那些停止工作的基本警告发送WM_CLOSE命令（而且，这些日子，让它们永久消失需要本地管理员权限）。
我无法想象谁会写这样的剧本，这是一个糟糕的主意！
该决定存在后果和附带损害：单线程VBA环境中的WsScript.Popup（）对象实现了他们的＆＃39; SecondsToWait＆＃39;使用Timer回调超时，并且该回调发送WM_CLOSE消息，或类似的东西......在大多数情况下会被忽略，因为它是回调线程，而不是对话框的所有者线程。
可以让它在带有“取消”的弹出窗口中工作。按钮，它会在一两分钟内变得清晰。
我已尝试在WM_CLOSE弹出窗口中编写定时器回调，在大多数情况下，这对我来说也失败了。
我尝试过一些异乎寻常的API回调来搞乱VBA.MsgBox和WsShell.Popup窗口，我现在可以告诉你，他们没有工作。你无法处理那些不存在的东西：那些对话窗口非常简单，除了按钮点击中的响应外，大多数都不包含任何功能 - 是，否，确定，取消，中止，重试，忽略和帮助。
＆＃39;取消＆＃39;是一个有趣的问题：当您指定vbOKCancel或vbRetryCancel或vbYesNoCancel - ＆＃39;取消＆＃时，您可以从原始Windows API获取内置对话框的免费赠品39;功能是通过关闭＆＃39;自动实现的。对话框菜单栏中的按钮（您不能通过其他按钮获取该按钮，但可以使用包含“忽略＆＃39;”的对话框进行尝试，这意味着...... 。
objWShell.PopUp("Test Me", 10, "Dialog Test", vbQuestion + vbOkCancel)
如果你想要的是让WsShell.Popup（）函数再次响应SecondsToWait参数，那对于阅读此内容的人来说，这可能是一个很好的解决方法。
这也意味着您可以向＆＃39;取消＆＃39;发送WM_CLOSE消息。在回调上使用SendMessage（）API调用的对话框：
SendMessage(hwndDlgBox, WM_CLOSE, ByVal 0&, ByVal 0&)
严格地说，这应仅适用于WM_SYSCOMMAND, SC_CLOSE消息 - ＆＃39}关闭＆＃39;命令栏中的框是一个＆＃39;系统＆＃39;菜单有一个特殊的命令类，但就像我说的那样，我们从Windows API获得免费赠品。
我开始工作了，我开始思考：如果我只能在那里工作，那么我可能会更好地了解实际上有什么 ...
答案显而易见：对话框有自己的一组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
并且，因为这些是＆＃39;用户＆＃39;如果消息将用户响应返回给对话框的调用者（也就是调用线程），则对话框很乐意接受它们并自行关闭。
您可以查询对话窗口以查看它是否实现了特定命令，如果是，则可以发送该命令：
If GetDlgItem(hWndMsgBox, vbRetry) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, vbRetry, 0&
Exit For
End If
剩下的挑战是检测“超时”＆＃39;并拦截返回的Message Box响应，并替换我们自己的值：-1如果我们遵循WsShell.Popup()函数建立的约定。所以我们的msgPopup＆＃39;具有超时的消息框的包装器需要做三件事：
在其他地方，我们需要为所有这些声明API调用，我们绝对必须已公开声明＆＃39; TimerProc＆＃39; Timer API调用的函数。该功能必须存在，并且必须运行到“结束功能”。没有错误或断点 - 任何中断，API Timer（）将调低操作系统的愤怒。
Option Explicit
Option Private Module<BR />
' Nigel Heffernan January 2016<BR />
' Modified from code published by Microsoft on MSDN, and on StackOverflow: this code is in<BR />' the public domain.<BR />
' This module implements a message box with a 'timeout'<BR />
' It is similar to implementations of the WsShell.Popup() that use a VB.MessageBox interface
' with an additional 'SecondsToWait' or 'Timeout' parameter.<BR />
Private m_strCaption As String<BR />
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult<BR />
' 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.<BR />
Dim TimerStart As Single<BR />
If Title = "" Then
Title = ThisWorkbook.Name
End If<BR />
If SecondsToWait > 0 Then
' TimedmessageBox launches a callback to close the MsgBox dialog
TimedMessageBox Title, SecondsToWait
TimerStart = VBA.Timer
End If<BR /><BR />
MsgPopup = MsgBox(Prompt, Buttons, Title)<BR /><BR />
If SecondsToWait > 0 Then
' Catch the timeout, substitute -1 as the response
If (VBA.Timer - TimerStart) >= SecondsToWait Then
MsgPopup = -1
End If
End If<BR />
End Function<BR />
Public Function MsgBoxResultText(ByVal MsgBoxResult As VbMsgBoxResult) As String<BR />' Returns a text value for the integers returned by VBA MsgBox() and WsShell.Popup() dialogs<BR />
' Additional value: 'TIMEOUT', returned when the MsgBoxResult = -1<BR />' All other values return the string 'ERROR'<BR /><BR />
On Error Resume Next<BR /><BR />
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<BR />End Function
'
'
'
'
'
'
'
'
'
'
Private Property Get MessageBox_Caption() As String
MessageBox_Caption = m_strCaption
End Property<BR />
Private Property Let MessageBox_Caption(NewCaption As String)
m_strCaption = NewCaption
End Property<BR /><BR />
Private Sub TimedMessageBox(Caption As String, Seconds As Long)
On Error Resume Next<BR />
' REQUIRED for Function msgPopup
' Public Sub TimerProcMessageBox MUST EXIST<BR />
MessageBox_Caption = Caption<BR />
SetTimer 0&, 0&, Seconds * 1000, AddressOf TimerProcMessageBox<BR />
Debug.Print "start Timer " & Now<BR />
End Sub<BR />
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows<BR /> ' Use LongLong and LongPtr<BR /><BR />
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As LongLong)
On Error Resume Next<BR />
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx<BR />
' 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.<BR />
' The MsgPopup implementation in this project returns -1 for this 'Timeout'<BR />
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox<BR />
KillTimer hWndMsgBox, idEvent<BR />
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)<BR />
If hWndMsgBox <> 0 Then<BR />
' 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<BR />
End If<BR />
End Sub<BR />
#ElseIf VBA7 Then ' 64 bit Excel in all environments<BR /> ' Use LongPtr only<BR /><BR />
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As Long)
On Error Resume Next<BR />
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx<BR />
' 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.<BR />
' The MsgPopup implementation in this project returns -1 for this 'Timeout'<BR />
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox
Dim iDlgCommand As VbMsgBoxResult ' Dialog command values: OK, CANCEL, YES, NO, etc<BR />
KillTimer hwnd, idEvent<BR />
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)<BR />
If hWndMsgBox <> 0 Then<BR />
' 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<BR />
End If<BR />
End Sub<BR />
#Else ' 32 bit Excel<BR /><BR />
Public Sub TimerProcMessageBox(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
On Error Resume Next<BR />
' REQUIRED for Function msgPopup<BR />
' The MsgPopup implementation in this project returns -1 for this 'Timeout'<BR />
Dim hWndMsgBox As Long ' Handle to VBA MsgBox<BR />
KillTimer hwnd, idEvent<BR />
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)<BR />
If hWndMsgBox <> 0 Then<BR />
' 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<BR />
End If<BR />
End Sub<BR />
#End If
以下是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" _<BR /> (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
最后一点：我欢迎有经验的MFC C ++开发人员提出改进建议，因为您将更好地掌握基本的Windows消息传递概念，以及对话框的基础知识。窗口 - 我用一种过于简单的语言工作，我的理解中的过度简化可能在我的解释中突然变成了直接的错误。
答案 1 :(得分：5)
使用答案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
答案 2 :(得分：0)
从这篇文章中的示例开始，我的最终代码如下：
' Coded by Clint Smith
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' tMsgBox Function (Timered Message Box)
' By Clint Smith, clintasm@gmail.com
' Created 04-Sep-2014
' 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.
' This was written using undocumented procedure in user32.dll
' due to a buggy WScript.shell result where message window did
' not close after timer expiration.
'
' Defaults to regular information top most message box with ok
' button only.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
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
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)
AppHWnd = FindWindow(wParentType, wParentName)
tMsgBoxResult = tMsgBoxA(AppHWnd, sMessage, sTitle, hNtype, hLangID, 1000 * iTimer)
End Sub
答案 3 :(得分：0)
易
Call CreateObject("WScript.Shell").Popup("Timed message box", 1, "Title", vbOKOnly)
答案 4 :(得分：0)
$(document).ready(function(){
if ($('.dashboard__icon--small.fa.fa-circle').hasClass('text-info')) {
$('.dashboard__icon.fa.fa-circle').addClass('text-info');
}
});