这是一个很长的答案，但有很多理由要涵盖：这也是一个迟到的回复，但是自从对这个（和类似问题）的一些回复已经发布在堆栈上之后，情况发生了变化。这就像三相交流电上的真空吸尘器一样糟糕，因为它们在发布时是很好的答案，并且经过了很多思考。
简短的版本是：我注意到一年前在 VBA 中 Script WsShell Popup 解决方案停止为我工作，我为 VBA MsgBox 函数编写了一个有效的 API 计时器回调。
如果您急需答案，请直接跳至标题VBA 代码以调用带有超时的消息框 下的代码 - 我确实做到了，我确实有数千个自我实例-dismissing 'MsgPopup' 替代 VBA.MsgBox 来编辑，下面的代码适合一个独立的模块。
但是，这里的 VBA 编码人员（包括我自己）需要解释一下为什么完美的代码似乎不再有效。如果您了解其中的原因，您或许可以对隐藏在文本中的“取消”对话框使用部分解决方法。
我注意到一年前 Script WsShell Popup 解决方案在 VBA 中停止为我工作 - 'SecondsToWait' 超时被忽略，对话框就像熟悉的 VBA.MsgBox 一样悬空：
MsgPopup = objWShell.PopUp(Prompt, SecondsToWait, Title, Buttons)
我想我知道原因：您不能再从打开它的线程以外的任何地方向对话窗口发送 WM_CLOSE 或 WM_QUIT 消息。同样，User32 DestroyWindow() 函数不会关闭对话框窗口，除非它被打开对话框的线程调用。
Redmond 的某个人不喜欢在后台运行脚本并向所有那些停止工作的重要警告发送 WM_CLOSE 命令的想法（而且，如今，让它们永久消失需要本地管理员权限）。
我无法想象谁会写出这样的剧本，这是个糟糕的主意！
该决定会产生后果和附带损害：单线程 VBA 环境中的 WsScript.Popup() 对象使用 Timer 回调实现其“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 Timer 以延迟关闭对话框；
- 打开消息框，传入常用参数；
- 要么：检测超时并替换“超时”响应...
...或者返回用户对对话框的响应，如果他们在
时间
在其他地方，我们需要为所有这些声明 API 调用，并且我们绝对必须有一个公开声明的“TimerProc”函数供 Timer API 调用。该函数必须存在，并且必须在没有错误或断点的情况下运行到“结束函数” - 任何中断，API Timer() 将调用操作系统的愤怒。
使用超时调用消息框的 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 消息传递概念 - 我使用一种过于简单的语言很可能我的理解过于简单化了，导致我的解释完全错误。