How to open a timed Message Box in MS ACCES without creating additional window

Question

On pressing a Save button on a form, I would like to run a Timed Message Box that closes automatically after 1 second. The default MsgBox command does not disappear until user presses OK or Exit.

So far, I have a solution from online search:

Public Sub Timed_Box (dur AS Long)

Dim WSH AS IWshRuntimeLibrary.WshShell
Dim Res AS Long

Set WSH = IWshRuntimeLibrary.WshShell

Res = WSH.PopUp(Text:="Record Updated", secondstowait:=dur, _ 
Title:="Update", Type:=vbOKOnly)

End Sub

It works fine. However, the problem is that it creates a temporary Window on desktop Taskbar for the duration which is quite annoying for a user to see. Is there anyway, I can hide this window from appearing on taskbar while still display message similar to MsgBox?

Answer 1

Here is my wrapper for MessageBoxTimeout to simplify the call. Instead of returning timeout information, I needed to return the default button value. The order of parameters and default values follows the original MsgBox function for better use.

Option Compare Database

#If VBA7 Then
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#Else
Private Declare Function MsgBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#End If

Public Enum vbMsgBoxTimeoutResult
    vbTimeout = 32000
End Enum

'// If parameter msgTimeoutMilliseconds < 1 then the message box will not close by itself.
'// The default timeout is set to 15 sec
'//
Public Function MsgBoxTimeout(ByVal msgText As String, Optional ByVal msgButtons As VbMsgBoxStyle = vbOKOnly, Optional ByVal msgTitle As String = vbNullString, Optional ByVal msgTimeoutMilliseconds As Long = 15000) As VbMsgBoxResult

   'Always set minimal timeout to 1 sec
    If msgTimeoutMilliseconds < 1000 Then msgTimeoutMilliseconds = 1000

    MsgBoxTimeout = MessageBoxTimeoutA(Application.hWndAccessApp, msgText, msgTitle, msgButtons, 0, msgTimeoutMilliseconds)
    
    'timeout action
    If MsgBoxTimeout = VbMsgBoxTimeoutResult_Timeout Then
        
        Dim defaultButtonFlag
        
        'get default button
        defaultButtonFlag = vbDefaultButton1
        If msgButtons And vbDefaultButton4 Then defaultButtonFlag = vbDefaultButton4
        If msgButtons And vbDefaultButton3 Then defaultButtonFlag = vbDefaultButton3
        If msgButtons And vbDefaultButton2 Then defaultButtonFlag = vbDefaultButton2
        
        'get only buttons information
        msgButtons = msgButtons And 7

        'return default value
        If msgButtons = vbYesNo Then
            
            If defaultButtonFlag = vbDefaultButton2 Then
                MsgBoxTimeout = vbNo
            Else
                MsgBoxTimeout = vbYes
            End If
            
        ElseIf msgButtons = vbYesNoCancel Then
            
            If defaultButtonFlag = vbDefaultButton3 Then
                MsgBoxTimeout = vbCancel
            ElseIf defaultButtonFlag = vbDefaultButton2 Then
                MsgBoxTimeout = vbNo
            Else
                MsgBoxTimeout = vbYes
            End If
        
        ElseIf msgButtons = vbAbortRetryIgnore Then
            
            If defaultButtonFlag = vbDefaultButton3 Then
                MsgBoxTimeout = vbIgnore
            ElseIf defaultButtonFlag = vbDefaultButton2 Then
                MsgBoxTimeout = vbRetry
            Else
                MsgBoxTimeout = vbAbort
            End If
    
        ElseIf msgButtons = vbOKCancel Then
         
            If defaultButtonFlag = vbDefaultButton2 Then
                MsgBoxTimeout = vbCancel
            Else
                MsgBoxTimeout = vbOK
            End If
        
        ElseIf msgButtons = vbOKOnly Then
        
            MsgBoxTimeout = vbOK
            
        Else
        
            'do nothing, already MsgBoxTimeout = vbMsgBoxTimeoutResult.vbTimeout
        
        End If
        
    End If
    
End Function

Answer 2

I wrote an additional answer instead of just a comment, because it seems to be too important to the requested context.

Lone wrote regarding MatteoNNZ's answer:

Thanks for sharing, the result is no different from what I am achieving with my existing code. Your code also produced a Temporary Window on taskbar.

---

But it's just a small step away from your needs!

Just provide the handle of your Microsoft Access Window (Application.hWndAccessApp) to the Api to let the resulting message box be 'visually bound' to Microsoft Access:

MsgBoxTimeout Application.hWndAccessApp, "This message box will be closed after 1 second ", "Automatically closing MsgBox", vbInformation, 0, 1000

Update 2019-04-05

Here is a wrapper for the MessageBoxTimeout to simplify the calling.

The order of the parameters and their default values follow the original MsgBox function.

It uses the original API function namens to free this name for the user defined procedure.

I added an enumeration for the timeout return value 32000.

You should take care to add proper error handling.

#If VBA7 Then
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#Else
Private Declare Function MsgBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#End If

Public Enum VbMsgBoxTimeoutResult
    Timeout = 32000
End Enum

'// If parameter msgTimeoutMilliseconds < 1 then the message box will not close by itself.
'// There is one additional return value to the values of VbMsgBoxResult:
'// If the message box timed out it returns 32000 (VbMsgBoxTimeoutResult.Timeout).
Public Function MsgBoxTimeout(ByVal msgText As String, Optional ByVal msgButtons As VbMsgBoxStyle = vbOKOnly, Optional ByVal msgTitle As String = vbNullString, Optional ByVal msgTimeoutMilliseconds As Long = 0) As VbMsgBoxResult
    MsgBoxTimeout = MessageBoxTimeoutA(Application.hWndAccessApp, msgText, msgTitle, msgButtons, 0, msgTimeoutMilliseconds)
End Function

An usage example:

Select Case MsgBoxTimeout("Foo", vbYesNo + vbQuestion, "Bar", 5000)
    Case VbMsgBoxTimeoutResult.Timeout
        Debug.Print "MessageBox timed out."
    Case vbYes
        Debug.Print "User selected 'Yes'."
    Case Else
        Debug.Print "User selected 'No'."
End Select

Answer 3

You can use the MsgBoxTimeout function provided in the library user32 of Windows.

Declare the following on top of your module:

#If Win64 Then 'If the system is in 64b
    Private Declare PtrSafe Function MsgBoxTimeout _
        Lib "user32" _
        Alias "MessageBoxTimeoutA" ( _
            ByVal hwnd As LongPtr, _
            ByVal lpText As String, _
            ByVal lpCaption As String, _
            ByVal wType As VbMsgBoxStyle, _
            ByVal wlange As Long, _
            ByVal dwTimeout As Long) _
    As Long
#Else 'if it's in 32b
    Private Declare Function MsgBoxTimeout _
        Lib "user32" _
        Alias "MessageBoxTimeoutA" ( _
            ByVal hwnd As Long, _
            ByVal lpText As String, _
            ByVal lpCaption As String, _
            ByVal wType As VbMsgBoxStyle, _
            ByVal wlange As Long, _
            ByVal dwTimeout As Long) _
    As Long
#End If

Then use it like this:

MsgBoxTimeout 0, "This message box will be closed after 1 second ", "Automatically closing MsgBox", vbInformation, 0, 1000

Some useful notes:

• The #If Win64 Then part is a macro determining at compile time what declaration to use. In 64b systems, in fact, every function declared by an external library should use the PtrSafe (pointer-safe) keyword which doesn't exist in 32b systems.
• You pass the timeout in milliseconds, that's why the parameter is 1000 when you want it to wait 1 second.

Answer 4

An option is to create your own messagebox. This you can open with a timeout:

' API call for sleep function.
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Public Function OpenFormDialog( _
    ByVal FormName As String, _
    Optional ByVal TimeOut As Long, _
    Optional ByVal OpenArgs As Variant = Null) _
    As Boolean

' Open a modal form in non-dialogue mode to prevent dialogue borders to be displayed
' while simulating dialogue behaviour using Sleep.

' If TimeOut is negative, zero, or missing:
'   Form FormName waits forever.
' If TimeOut is positive:
'   Form FormName exits after TimeOut milliseconds.

    Const SecondsPerDay     As Single = 86400

    Dim LaunchTime          As Date
    Dim CurrentTime         As Date
    Dim TimedOut            As Boolean
    Dim Index               As Integer
    Dim FormExists          As Boolean

    ' Check that form FormName exists.
    For Index = 0 To CurrentProject.AllForms.Count - 1
        If CurrentProject.AllForms(Index).Name = FormName Then
            FormExists = True
            Exit For
        End If
    Next
    If FormExists = True Then
        If CurrentProject.AllForms(FormName).IsLoaded = True Then
            ' Don't reopen the form should it already be loaded.
        Else
            ' Open modal form in non-dialogue mode to prevent dialogue borders to be displayed.
            DoCmd.OpenForm FormName, acNormal, , , , acWindowNormal, OpenArgs
        End If
        ' Record launch time and current time with 1/18 second resolution.
        LaunchTime = Date + CDate(Timer / SecondsPerDay)
        Do While CurrentProject.AllForms(FormName).IsLoaded
            ' Form FormName is open.
            ' Make sure form and form actions are rendered.
            DoEvents
            ' Halt Access for 1/20 second.
            ' This will typically cause a CPU load less than 1%.
            ' Looping faster will raise CPU load dramatically.
            Sleep 50
            If TimeOut > 0 Then
                ' Check for time-out.
                CurrentTime = Date + CDate(Timer / SecondsPerDay)
                If (CurrentTime - LaunchTime) * SecondsPerDay > TimeOut / 1000 Then
                    ' Time-out reached.
                    ' Close form FormName and exit.
                    DoCmd.Close acForm, FormName, acSaveNo
                    TimedOut = True
                    Exit Do
                End If
            End If
        Loop
        ' At this point, user or time-out has closed form FormName.
    End If

    ' Return True if the form was not found or was closed by user interaction.
    OpenFormDialog = Not TimedOut

End Function

It does, however, take a lot more code to obtain the full functionality of a messagebox, but it is carefully described and for download in my article:

Modern/Metro style message box and input box for Microsoft Access 2013+

Code is also at GitHub: VBA.ModernBox