显示带有超时值的消息框

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.将对 wscript.popup 方法的调用包装在 MSHTA 进程中，这将允许代码在进程外运行并避免 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

这是一个很长的答案，但有很多基础内容需要涵盖：这也是一个迟到的答复，但自从对此（以及类似问题）的一些答复已发布在堆栈上以来，事情已经发生了变化。这就像三相交流电上的吸尘器一样糟糕，因为它们在发布时是很好的答案，并且经过了很多思考。

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

直接跳到下面的代码如果您急需答案，标题调用超时消息框的 VBA 代码 - 我确实这样做了，我确实有数千个自动解除“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() 对象使用 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 获得免费赠品。

我开始工作，然后我开始思考：如果我只能使用现有的东西，也许我最好找出实际存在的东西...

答案很明显：Dialog框有自己的一组 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”包装器需要执行三件事：

1. 调用我们的 API 计时器以延迟关闭对话框；
2. 打开消息框，传入常用参数；
3. 要么：检测超时并替换“超时”响应...
   ...或者将用户响应返回到对话框，如果他们响应
   在

其他地方，我们需要声明所有这些的 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 消息传递概念 - 我使用一种过于简单化的语言工作，并且我的理解中的过度简化很可能已经超出了我的解释中的彻底错误。

Answer 2

采用答案 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

Answer 3

简单的

Call CreateObject("WScript.Shell").Popup("Timed message box", 1, "Title", vbOKOnly)

Answer 4

从这篇文章中的示例开始，我的最终代码如下：

' 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

Answer 5

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
                btnAbort    = False
                btnRetry    = False
                btnIgnore   = False
                btnYes      = False
                btnNo       = False
                MsgTimeOut  = False
                Exit Function
            Case 2
                btnOK       = False
                btnCancel   = True
                btnAbort    = False
                btnRetry    = False
                btnIgnore   = False
                btnYes      = False
                btnNo       = False
                MsgTimeOut  = False
                Exit Function
            Case 3
                btnOK       = False
                btnCancel   = False
                btnAbort    = True
                btnRetry    = False
                btnIgnore   = False
                btnYes      = False
                btnNo       = False
                MsgTimeOut  = False
                Exit Function
            Case 4
                btnOK       = False
                btnCancel   = False
                btnAbort    = False
                btnRetry    = True
                btnIgnore   = False
                btnYes      = False
                btnNo       = False
                MsgTimeOut  = False
                Exit Function
            Case 5
                btnOK       = False
                btnCancel   = False
                btnAbort    = False
                btnRetry    = False
                btnIgnore   = True
                btnYes      = False
                btnNo       = False
                MsgTimeOut  = False
                Exit Function
            Case 6
                btnOK       = False
                btnCancel   = False
                btnAbort    = False
                btnRetry    = False
                btnIgnore   = False
                btnYes      = True
                btnNo       = False
                MsgTimeOut  = False
                Exit Function
            Case 7
                btnOK       = False
                btnCancel   = False
                btnAbort    = False
                btnRetry    = False
                btnIgnore   = False
                btnYes      = False
                btnNo       = True
                MsgTimeOut  = False
                Exit Function
            Case 32000
                btnOK       = False
                btnCancel   = False
                btnAbort    = False
                btnRetry    = False
                btnIgnore   = False
                btnYes      = False
                btnNo       = False
                MsgTimeOut  = True

    Next TimeOutCounter

End Function