#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long) As Long
#Else
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As Long
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long) As Long
#End If
Private MsgBoxWindowTitle As String
Private MsgBoxTimeOutReached As Boolean
'-----------------------------
'MsgBox with Time Out Function
'-----------------------------
'https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/msgbox-function
'Call: MsgBoxTimeOut (prompt, [ buttons, ] [ title, ] [ helpfile, context ,] [ dwMilliseconds ])
'Return: MsgBox values
' -1 if TimeOut
'------------------------
Function MsgBoxTimeOut(ByVal prompt As String, _
Optional ByVal buttons As Long = 0, _
Optional ByVal title As String = "", _
Optional ByVal helpfile As String = "", _
Optional ByVal context As Long = 0, _
Optional ByVal dwMilliseconds As Long = 0) As Integer
Dim RetVal As Integer
Dim TimerID As Long
Const DefaultExcelTitle = "Microsoft Excel"
'Initialisations
If Len(title) Then MsgBoxWindowTitle = title Else MsgBoxWindowTitle = DefaultExcelTitle
MsgBoxTimeOutReached = False
'Set Timer
If dwMilliseconds > 0 Then TimerID = SetTimer(0, 0, IIf(dwMilliseconds < 300, 300, dwMilliseconds), AddressOf MsgBoxTimeOutFunction)
'Standard MsgBox
RetVal = MsgBox(prompt, buttons, MsgBoxWindowTitle, helpfile, context)
'Kill Timer
If TimerID Then KillTimer 0, TimerID
'Return value
If MsgBoxTimeOutReached Then MsgBoxTimeOut = -1 Else MsgBoxTimeOut = RetVal
End Function
'-----------------
'Time Out Function
'-----------------
Private Sub MsgBoxTimeOutFunction()
'To ensure that SendKeys does not target another application
AppActivate MsgBoxWindowTitle
'Close MsgBox Window
SendKeys "{ENTER}"
'Time Out Flag
MsgBoxTimeOutReached = True
End Sub