Show Message Box for Limited Time Period before continuing with remainder of code

[vanhunk]

Show Message Box for Limited Time Period to allow User to hit Cancel button, before automatically continuing with the remainder of the code:

Is it possible to put a timer on a message box? I want to give the user the option to opt out of the code before it continues to run automatically.

The idea is to trigger the code automatically if a certain condition is met, e.g. a certain date reached, and warn the user that the code is going to execute unless "Cancel" is pressed within a preset time period.

If "Cancel" is not pressed, the code will continue to run as intended.

Regards,
vanhunk

[Paul_Hossler]

Here's some code I use for timed messages. I like to 'wrap' reusable pieces in a 'as general as possible' sub or function so it might be more involved than you need

I added a Test sub to explain it



Option Explicit
Sub test()
Dim aResponseText As Variant

Dim i As Long

aResponseText = Array("No Response", "OK", "Cancel", "Abort", "Retry", "Ignore", "Yes", "No")
i = MsgBoxTimed("Do not touch -- Three Seconds", "Test Timed Msgbox", vbExclamation, vbOKOnly, , 3)
MsgBox "Returned from function -- You can click now = " & aResponseText(i)
i = MsgBoxTimed("Do not touch -- 'Yes' in Three Seconds - ", "Test Timed Msgbox (Y/N)", vbCritical, vbYesNo, vbDefaultButton1, 3)
MsgBox "Returned from function -- You can click now = " & aResponseText(i)

i = MsgBoxTimed("Do not touch -- 'No' in Three Seconds - ", "Test Timed Msgbox (Y/N)", vbCritical, vbYesNo, vbDefaultButton2, 3)
MsgBox "Returned from function -- You can click now = " & aResponseText(i)

i = MsgBoxTimed("User override default -- 'Click 'Yes' within 10 seconds, otherwise default = 'No'", "Test Timed Msgbox (Y/N)", vbCritical, vbYesNo, vbDefaultButton2, 10)
MsgBox "Returned from function -- You can click now = " & aResponseText(i)

i = MsgBoxTimed("Waiting for user input", "Test Timed Msgbox", vbExclamation, , , 0)
MsgBox "Returned from function -- You can click now = " & aResponseText(i)

End Sub

Function MsgBoxTimed(sMsg As String, sTitle As String, _
Optional MsgIcon As VbMsgBoxStyle = vbInformation, _
Optional MsgButtons As VbMsgBoxStyle = vbOKOnly, _
Optional MsgButtonsDefault As VbMsgBoxStyle = vbDefaultButton1, _
Optional SecDelay As Long = 0) _
As VbMsgBoxResult

Const vbNoResponse As Long = -1
Dim iResponse As VbMsgBoxResult, iDefault As VbMsgBoxResult
Dim iWait As Long
Dim objShell As Object

Select Case MsgButtons
Case vbOKOnly
iDefault = vbOK

Case vbOKCancel
If MsgButtonsDefault = vbDefaultButton1 Then
iDefault = vbOK
Else
iDefault = vbCancel
End If
Case vbAbortRetryIgnore
If MsgButtonsDefault = vbDefaultButton1 Then
iDefault = vbAbort
ElseIf MsgButtonsDefault = vbDefaultButton2 Then
iDefault = vbRetry
Else
iDefault = vbIgnore
End If
Case vbYesNoCancel
If MsgButtonsDefault = vbDefaultButton1 Then
iDefault = vbYes
ElseIf MsgButtonsDefault = vbDefaultButton2 Then
iDefault = vbNo
Else
iDefault = vbCancel
End If
Case vbYesNo
If MsgButtonsDefault = vbDefaultButton1 Then
iDefault = vbYes
Else
iDefault = vbNo
End If
Case vbRetryCancel
If MsgButtonsDefault = vbDefaultButton1 Then
iDefault = vbRetry
Else
iDefault = vbCancel
End If
End Select


'display the box, and return the value
Set objShell = CreateObject("WScript.Shell")
DoEvents
iResponse = objShell.Popup(sMsg, SecDelay, sTitle, _
MsgIcon + MsgButtons + MsgButtonsDefault + vbSystemModal)
Set objShell = Nothing

If iResponse = vbNoResponse Then
MsgBoxTimed = iDefault
Else
MsgBoxTimed = iResponse

End If
End Function

[vanhunk]

@Paul:
I am working in Excel 2013 and it does not work. I am not sure whether the message box will disappear after a couple of seconds (that is what I would like to happen), it doesn't though. The result is also always the one I select, regardless of waiting or not, i.e. it does not apply the default value after the prescribed waiting time (I want the default value to be taken forward if the user did not respond within the prescribed time.

Regards,
vanhunk

[snb]

Sub M_snb()
If CreateObject("Wscript.shell").Popup("wacht....", 3, "snb", 1) = 2 Then Exit Sub
End Sub

It should disappear after 3 seconds.

[mikerickson]

This worked on my Mac

Sub test()
Dim strPrompt As String, strButton As String, Delay As String
Dim strScript As String

strPrompt = "hello"
Delay = 3

strButton = Chr(34) & "OK" & Chr(34)
strPrompt = Chr(34) & strPrompt & Chr(34)

strScript = "display dialog " & strPrompt & " buttons {" & strButton & "} default button " & strButton
strScript = strScript & "giving up after " & Delay

If (MacScript(strScript)) Like "*gave up:true" Then
MsgBox "timed out"
Else
MsgBox "user clicked OK button"
End If
End Sub

[vanhunk]

@snb, @mikerickson,
Thank you guys, it is working perfectly. I went with snb's approach and found a link explaining it in detail:

https://technet.microsoft.com/en-us/library/ee156593.aspx

Regards,
vanhunk

[Paul_Hossler]

Glad you got it

I compared snb's to what I've been using and as far as I can tell the only difference is the + vbSystemModal on the .Popup call



iResponse = objShell.Popup(sMsg, SecDelay, sTitle, _
MsgIcon + MsgButtons + MsgButtonsDefault + vbSystemModal)



Mine works fine in my 2010, so I'm wondering if vbSystemModal is different in 2013

If you get a chance, could you try my function again with the vbSystemModal removed and let me know?

Thanks

[vanhunk]

@Paul:
Thanks Paul, seems to be working just fine now!

Best Regards,
vanhunk

[vanhunk]

@snb,@paul:
PROBLEM: It does not work every time. Normally it works the first time, and then after that it often freeze at the message box, i.e. it does not continue automatically after timeout.

Thanks

[Aflatoon]

The Shell Popup method is unreliable. (you will find many thousands of mentions of this if you search the web) You'd be better off with a userform which you can show modelessly and then use a loop to wait for input or dismiss it. You could also use API calls to dismiss a regular message box with a CBT hook, but the userform is simpler.

[vanhunk]

@Aflatoon:
Thank you for this information, do you perhaps have examples of the methods you mentioned?

Regards,
vanhunk

[Aflatoon]

Here's a simple userform.

[vanhunk]

@Aflatoon: Thank you very much, I appreciate it! Regards, vanhunk