顯示帶有超時值的消息框

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""))"

在 VBA 中顯示帶有超時值的消息框的 A、B 或 C 或您自己的答案的最佳方式是什么？

Answer 1

這是一個很長的答案，但有很多內容需要涵蓋：這也是一個遲到的回復，但自從對此（和類似問題）的一些回復發布在堆棧上后，情況發生了變化。 這就像三相交流電的真空吸塵器一樣糟糕，因為它們在發布時是很好的答案，並且經過了很多思考。

簡短的版本是：我注意到一年前腳本 WsShell Popup 解決方案在 VBA 中對我不起作用，我為 VBA MsgBox 函數編寫了一個有效的 API 計時器回調。

如果您急需答案，請直接跳到VBA 代碼標題下的代碼，以調用帶有超時的消息框- 我確實做到了，我確實有數千個自我忽略的“MsgPopup”實例替代 VBA.MsgBox編輯，下面的代碼適合一個獨立的模塊。

但是，這里的 VBA 編碼人員（包括我自己）需要解釋一下為什么完美的代碼似乎不再起作用。 如果您了解原因，您也許可以使用隱藏在文本中的“取消”對話框的部分解決方法。

我注意到腳本 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 中免費獲得內置對話框的免費vbYesNoCancel ——“取消”功能是通過在對話框中的“關閉”按鈕自動實現的對話框的菜單欄（您無法使用其他按鈕獲得該菜單欄，但您可以使用包含“忽略”的對話框隨意嘗試），這意味着....

如果 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

剩下的挑戰是檢測“超時”並攔截返回的消息框響應，並替換我們自己的值：-1 如果我們遵循WsShell.Popup()函數建立的約定。 所以我們的帶有超時的消息框的 'msgPopup' 包裝器需要做三件事：

1. 調用我們的 API Timer 以延遲關閉對話框；
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, clintasm@gmail.com
' 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