excel - 显示带有超时值的消息框

Question

问题来自这样的代码。

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/

我发现的解决方法是:

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.将手动计时器与旨在看起来像消息框的VBA用户窗体一起使用。使用全局变量或类似变量保存需要传递回调用代码的所有状态。确保使用提供的vbModeless参数调用用户窗体的Show方法。

C.在MSHTA流程中包装对wscript.popup方法的调用，这将使代码耗尽流程并避免Office的模式性。

CreateObject("WScript.Shell").Run "mshta.exe vbscript:close(CreateObject(""WScript.Shell"").Popup(""Test"",2,""Real%20Time%20Status%20Message""))"

用A，B或C或您自己的答案在VBA中显示带有超时值的消息框的最佳方法是什么？

Answer 1

这是一个很长的答案，但是有很多需要讲的内容:这也是一个较晚的答复，但是由于对此问题的一些答复(以及类似的问题)已被发布到堆栈中，因此情况发生了变化。这就像三相AC上的真空吸尘器一样，因为它们在张贴时是很好的答案，并且引起了很多思考。

简短的版本是:我注意到一年前Script WsShell Popup解决方案在VBA中对我停止工作了，我为VBA MsgBox函数编写了一个有效的API计时器回调。

如果急需答案，请直接跳至VBA代码标题下的代码，以使用超时调用消息框-我确实有数千个VBA自我解散“MsgPopup”替代品的实例.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计时器以延迟关闭对话框；

打开消息框，并传递通常的参数。

要么:检测超时，然后替换“超时”响应...
...或者如果用户响应，则将用户响应返回到对话框
时间

在其他地方，我们需要声明所有这些的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和普通 Vanilla 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消息传递概念-我的工作语言过于简单。我的理解过分简单，很可能使我的解释陷入了完全错误的境地。