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/.../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