虽然这是一个较长的回答，但要涵盖很多内容。由于一些评论在stack上发布后，情况已经发生了变化，所以我的回复来得有点晚，但它们在发布时是好的答案，并且已经付出了很多思考。
简短的版本是：我注意到Script WsShell Popup解决方案在VBA中已经停止工作一年了，因此我编写了一个可行的API计时器回调用于VBA MsgBox函数。
如果你需要快速得到答案，可以直接跳到标题为“VBA code to call a Message Box with a Timeout”的代码部分 - 我也是如此，我有成千上万个自动关闭的“MsgPopup”替代品需要更改为VBA.MsgBox，并且下面的代码适用于一个自包含模块。
然而，在此处的VBA编码人员（包括我自己）需要一些解释，以了解为什么完美的代码似乎不再起作用。如果您理解原因，您可能能够使用文本中隐藏的“取消”对话框的部分解决方法。
我注意到Script WsShell Popup解决方案在VBA中已经停止工作一年了-“SecondsToWait”超时被忽略，而对话框就像熟悉的VBA.MsgBox一样挂起：
MsgPopup = objWShell.PopUp(Prompt, SecondsToWait, Title, Buttons)
我认为原因是：您无法从打开对话框的线程以外的任何地方发送WM_CLOSE或WM_QUIT消息到对话框窗口。同样，User32 DestroyWindow（）函数不会关闭对话框窗口，除非它是由打开对话框的线程调用的。
有人不喜欢在后台运行脚本并向所有这些阻止您工作的重要警告发送WM_CLOSE命令的想法（而且，现在永久解决它们需要本地管理员权限）。
我无法想象谁会写出这样的脚本，这是一个可怕的想法！
这个决定有后果和附带损害：单线程VBA环境中的WsScript.Popup（）对象使用计时器回调来实现其“SecondsToWait”超时，该回调发送WM_CLOSE消息或类似的消息……大多数情况下会被忽略，因为它是回调线程，而不是对话框的所有者线程。
您可能会在具有“取消”按钮的弹出窗口上使其工作，并且一两分钟后就会清楚原因。
我尝试编写了一个计时器回调来 WM_CLOSE 弹出窗口，但在大多数情况下，它都失败了。
我尝试了一些异国情调的 API 回调来混淆 VBA.MsgBox 和 WsShell.Popup 窗口，现在我可以告诉您它们不起作用。您无法使用不存在的内容：那些对话框窗口非常简单，大多数情况下除了按钮点击的响应（是，否，确定，取消，中止，重试，忽略和帮助）之外没有任何功能。
“取消”是一个有趣的问题：当您指定vbOKCancel或vbRetryCancel或vbYesNoCancel时，原始Windows API中的内置对话框会自动实现“取消”函数，并在对话框的菜单栏中添加了一个“关闭”按钮（您不会获得其他按钮，但请随时尝试包含“忽略”的对话框），这意味着...WsShell.Popup（）对话框有时会对SecondsToWait超时响应，如果它们具有“取消”选项。
objWShell.PopUp("Test Me", 10, "Dialog Test", vbQuestion + vbOkCancel)
如果您只是想让WsShell.Popup()函数再次响应SecondsToWait参数，那么这可能是一个足够好的解决方法。
这也意味着您可以使用回调函数上的SendMessage() API调用向“取消”对话框发送WM_CLOSE消息：
SendMessage(hwndDlgBox, WM_CLOSE, ByVal 0&, ByVal 0&)
严格来说，这只适用于 WM_SYSCOMMAND, SC_CLOSE 消息 - 命令栏中的“关闭”框是具有特殊命令类的“系统”菜单，但像我说的那样，我们从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
同时，由于这些是返回用户响应给对话框调用者（也就是说，调用线程）的“用户”消息，因此对话框很乐意接受它们并关闭自己。
您可以查询对话框窗口是否实现了特定命令，如果实现了，您可以发送该命令：
If GetDlgItem(hWndMsgBox, vbRetry) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, vbRetry, 0&
Exit For
End If
剩余的挑战是检测“超时”，拦截返回的消息框响应，并替换为我们自己的值：如果我们遵循WsShell.Popup()函数所建立的约定，则为-1。因此，我们用于带有超时的消息框的'msgPopup'包装器需要执行三件事：
- 调用 API 定时器进行对话框的延迟取消；
- 打开消息框，传递常规参数；
- 要么：检测超时并替换“超时”响应……
要么在时间内返回用户对话框响应
此外，我们需要声明所有这些API调用，而且我们绝对必须有一个公开声明的'TimerProc'函数供定时器API调用。该函数必须存在，并且必须在没有错误或断点的情况下运行到“End Function”——任何中断都会导致API定时器()调用操作系统的愤怒。
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
以下是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
最后注意：我欢迎有经验的MFC C ++开发人员的改进建议，因为您对基本的Windows消息传递概念具有更好的掌握，这是“对话框”窗口的基础 - 我使用了一种过度简化的语言，很可能我的理解中的过度简化已经越过了在我的解释中直接出现错误的界限。
