Display a message box with a timeout value

Question

The question comes from code like this.

Set scriptshell = CreateObject(\"wscript.shell\")
    Const TIMEOUT_IN_SECS = 60
    Select Case scriptshell.popup(\"         


        

Answer 1

Starting with the samples in this post my final code is as follows:

' 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