Version 1.58	First Published 16 Apr 2026

My article: New Style Access Message Boxes With Timeout, demonstrated the MsgBoxT function, designed to create Fluent UI message boxes in Access 365 with a timeout feature.

In fact it was a multi-purpose function which can create each of the following message box types with or without a timeout:
•   new style Fluent UI message box with red header in Access 365 (Current Channel or faster)
•   old style message box with a bold first line
•   standard message box with no formatting

The MsgBoxT function also supports:
•   Unicode text in the title and message prompt
•   Links to online Help articles / local help files
•   Adapts to Office theme colours
•   Ease of Access features such as larger text size and high contrast themes

However, using the MsgBoxT function, a countdown isn't supported whilst the timeout feature is running. This is because Access message boxes are modal and therefore static in terms of their contents. That means the message cannot easily be intercepted during the timeout to provide a running countdown.

This article describes 3 different approaches which can be used to achieve this outcome. Each method is a workaround to the problem and has its own advantages and disadvantages:
1.   redraw the message box each second during the timeout
2.   add a countdown as an overlay to the message box
3.   use a custom message form



1.   Redraw the message box each second during the timeout

A potentially useful approach would be to modify the MsgBoxT function to include countdown text which is updated each second.
However, as the form is modal, this can only be done by intercepting the timeout each second, closing then redrawing a modified message on each occasion.

     

The code changes required are relatively simple. However, this leads for a poor user experience with the message box being reloaded each second.
It also makes it difficult to interrupt the countdown to click the message box buttons. I would not recommend this approach for most purposes.

The only time I would ever consider using this is for a long timeout of at least 60 seconds with the countdown updated at 10 second intervals or more.



2.   Add a countdown as an overlay to the message box

This approach is based on an original idea by my colleague, Xevi Batlle, who provided a substantial part of the code.
The countdown message text is separate from the message box but positioned so it overlays a suitable location on the timeout message box.

If the message box is moved during the timeout period, the overlay text moves automatically so it remains in the correct position.
The appearance and position of the countdown message can be modified to 'blend in' with the message style (Fluent UI / bold first line / standard message) and is updated as appropriate for the Office UI theme in use.

The approach is based on a modified version of the MsgBoxT function, renamed as MsgBoxTC, and with an additional optional boolean argument (Countdown) with a default value = False.

Syntax:     Items in [ ] are optional

MsgBoxT (Prompt, [Buttons], [Title], [HelpFile], [Context], [Timeout], [Countdown])

Example 1: Fluent UI Message with help file, 10 second timeout and countdown:

MsgBoxTC "Click the Help (?) button to view the linked help article online.@This message will close automatically after 10 seconds@", vbYesNoCancel + vbInformation + vbDefaultButton2, "MsgBox Timeout", "https://isladogs.co.uk/new-style-msgbox-timeout/", 2, 10000, True

Example 2: Fluent UI Message with Unicode text, 10 second timeout and countdown with Black Office UI theme:

MsgBoxTC "Παράδειγμα μηνύματος στα ελληνικά Υποστηρίζει επίσης χαρακτήρες Unicode σψϠΦϓ 🚗🛴🚲🚦 ΔΘΞΣρΛδ", vbRetryCancel + vbExclamation + vbDefaultButton2, "Greek ΔΘΞΣρΛδ", "", 0, 10000, True

Example 3: Old Style Message with bold first line, 5 second timeout and countdown:

MsgBoxTC "Old style messages also support 3 distinct text blocks each with 1 more more lines of text. The first block has bold text@Normal 2nd line @Message closes after 5 seconds.", vbOK + vbCritical, "Info", "", -1, 5000, True

The short video below (4:08) shows various examples of this function in use:

     

NOTE: An updated version of this video with additional explanations will be uploaded in the next week or so.

The code for the MsgBoxTC function is contained in a single module, modTimedMsgBoxCountdown.

Copy code
Option Compare Database
Option Explicit

'---------------------------------------------------------------------------------------
' Form      : modTimedMsgBoxCountdown
' DateTime  : 14/03/2026
' Author    : Colin Riddington (Mendip Data Systems); Xevi Batlle
' Website   : https://www.isladogs.co.uk
' Purpose   : Functions used to create a timeout & countdown version of the new style Fluent UI Access message box function
'             Also works for old style message box wityh bold first line and standard message box
' Copyright : The code in the utility MAY be altered and reused in your own applications
'             provided the copyright notice is left unchanged (including Author, Website and Copyright)
'             You are NOT allowed to sell, resell or repost this on other sites such as online forums
'             without permission from the author. However, links back to the above website ARE allowed.

'             If you find this code useful please place a link to my website on your own web site
'             so that others may benefit as well.
' Updated   : 2026-04-07
'---------------------------------------------------------------------------------------

'===========================
'  Win32 API Declarations
'===========================
'The following APIs are used to identify the handle for the message box and set the timer
'Finally the timer is destroyed if the message box is closed by the user

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-findwindoww
'Retrieves a handle to the top-level window whose class name and window name match the specified strings.
'Also works for unicode strings
Private Declare PtrSafe Function FindWindowW Lib "user32" _
    (ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr) As LongPtr
    
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-postmessagew
'Places (posts) a message in the message queue associated with the thread that created the specified window
'and returns without waiting for the thread to process the message.
Private Declare PtrSafe Function PostMessageW Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal wMsg As Long, _
     ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-settimer
'Creates a timer with the specified time-out value.
Private Declare PtrSafe Function SetTimer Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
     ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-killtimer
'Destroys the specified timer
Private Declare PtrSafe Function KillTimer Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long

'=============================================================
'The following APIs are used to manage the countdown overlay message
'=============================================================
#If Win64 Then
    'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-setwindowlongptra
    'SetWindowLongPtr is required for 64-bit Office to handle memory pointers safely
    'Changes an attribute of the specified window. The function also sets a value at the specified offset in the extra window memory.
    Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
        (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
    ' Standard 32-bit declaration
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
        (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If

'=============================================================
'Graphics Device Interface (GDI) and User32 functions for drawing and window management
'=============================================================

'https://learn.microsoft.com/en-us/windows/win32/api/wingdi/nf-wingdi-createsolidbrush
'Creates a logical brush that has the specified solid color.
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getwindowrect
'Retrieves the dimensions of the bounding rectangle of the specified window.
'The dimensions are given in screen coordinates that are relative to the upper-left corner of the screen.
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-showwindow
'Sets the specified window's show state.
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-createwindowexa
'Creates an overlapped, pop-up, or child window with an extended window style
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
        (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, _
        ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
        
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-destroywindow
'Destroys the specified window.
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-setlayeredwindowattributes
'Sets the opacity and transparency color key of a layered window
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, _
        ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
        
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-setwindowpos
'Changes the size, position, and Z order of a child, pop-up, or top-level window.
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
        ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/wingdi/nf-wingdi-deleteobject
'Deletes a logical pen, brush, font, bitmap, region, or palette, freeing all system resources associated with the object.
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/wingdi/nf-wingdi-settextcolor
'Sets the text color for the specified device context to the specified color.
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/wingdi/nf-wingdi-setbkmode
'Sets the text color for the specified device context to the specified color.
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-invalidaterect
'Adds a rectangle to the specified window's update region - the portion of the window's client area that must be redrawn.
Private Declare PtrSafe Function InvalidateRect Lib "user32" _
        (ByVal hwnd As LongPtr, lpRect As Any, ByVal bErase As Long) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-beginpaint
'Prepares the specified window for painting and fills a PAINTSTRUCT structure with information about the painting.
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr


'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getclientrect
'Retrieves the coordinates of a window's client area.
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-fillrect
'Fills a rectangle by using the specified brush.
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-drawtexta
'Draws formatted text in the specified rectangle.
Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As LongPtr, ByVal lpStr As String, _
        ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-callwindowproca
'Passes message information to the specified window procedure.
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
        (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, _
        ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
            
' --- Data Structures (UDTs) for API communication ---
Private Type Msg
    hwnd As LongPtr
    Message As Long
    wParam As LongPtr
    lParam As LongPtr
    time As Long
    ptX As Long
    ptY As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type PAINTSTRUCT
    hdc As LongPtr
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type

' --- Constants for Window Messages and Styles ---
Private Const DT_LEFT As Long = &H0 'CR
Private Const DT_CENTER As Long = &H1
Private Const DT_VCENTER As Long = &H4
Private Const DT_SINGLELINE As Long = &H20

Private Const WM_CLOSE As Long = &H10
Private Const WM_PAINT As Long = &HF
Private Const WM_ERASEBKGND As Long = &H14
Private Const WM_SETFONT As Long = &H30
Private Const WM_KEYDOWN     As Long = &H100
Private Const WM_KEYUP       As Long = &H101
Private Const WM_SYSKEYDOWN  As Long = &H104
Private Const WM_SYSKEYUP    As Long = &H105
Private Const WM_CHAR        As Long = &H102
Private Const WM_CTLCOLORSTATIC As Long = &H138

Private Const SS_CENTER As Long = &H1
Private Const SS_CENTERIMAGE As Long = &H200

Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_SHOWWINDOW As Long = &H40

' Common Stock Object Constants
Private Const WHITE_BRUSH As Long = 0
Private Const LTGRAY_BRUSH As Long = 1
Private Const GRAY_BRUSH As Long = 2
Private Const DKGRAY_BRUSH As Long = 3
Private Const BLACK_BRUSH As Long = 4
Private Const NULL_BRUSH As Long = 5
Private Const DC_BRUSH As Long = 18 ' Windows 2000 or later
Private Const DEFAULT_GUI_FONT As Long = 17
Private Const TRANSPARENT As Long = 1
Private Const GWL_WNDPROC As Long = -4
Private Const LWA_ALPHA As Long = &H2
Private Const HWND_TOPMOST As LongPtr = -1

Private Const SW_HIDE As Long = 0
Private Const SW_SHOWNOACTIVATE As Long = 4
Private Const SW_SHOW As Long = 5

Private Const WS_POPUP As Long = &H80000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_EX_LAYERED As Long = &H80000

Public Enum CountdownPosition
    PosTopLeft = 0
    PosTopRight = 1
    PosBottomLeft = 2
    PosBottomRight = 3
    PosCenter = 4
    PosTopCenter = 5
    PosbottomCenter = 6
End Enum

' Variables for the countdown window
Private hMainWnd As LongPtr
'Private hFont As LongPtr 'CR - removed v1.57
Private RemainingSeconds As Long
Private OldWndProc As LongPtr

'===========================
' Module-level state variables
'===========================
Private mTimedMsgTitle As String
Private mTimedResult As VbMsgBoxResult
Private mTimerFired As Boolean
Private mTextColor As Long
Private mBackGroundColor As Long
Private mOffsetLeft As Long
Private mOffsetTop As Long
Private mInitialSeconds As Long
Private mTransparency As Long
Private mProgressBar As Boolean
Private mPosMode As CountdownPosition

'===========================
' Timed MsgBox function with Countdown Window
' Main entry point to call a message box that auto-closes
'===========================
Public Function MsgBoxTC( _
        ByVal Prompt As String, _
        Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
        Optional ByVal Title As String = "", _
        Optional ByVal HelpFile As String = "", _
        Optional ByVal Context As Long = 0, _
        Optional ByVal Timeout As Long = 0, _
        Optional ByVal Countdown As Boolean = 0) As VbMsgBoxResult
        
    TempVars!Context = Context
    TempVars!Timeout = Timeout
    TempVars!Countdown = Countdown
    
    
    '******* Some countdown Windows settings that can be configured
    'Store the color for use in the window creation
    SetCountDownWindowColors
       
    'Set countdown window position
    mPosMode = PosTopLeft           'PosTopLeft, PosTopRight, PosBottomLeft, PosBottomRight, PosCenter, PosTopCenter, PosBottomCenter
       
    mTransparency = 240 ' From 0 to 255:  Countdown window transparency
    mProgressBar = True
    
    If Context >= 0 Then
        ' Offsets from the MsgBox Window where the countdown window will be displayed
        mOffsetLeft = 15 ' 20
        mOffsetTop = 6 '2
    Else 'put below title
        mOffsetLeft = 15 ' 20
        mOffsetTop = 35 '2
    End If
    ' ***********************************************************
    
    ' Reset state variables for each message
    mTimerFired = False
    mTimedResult = GetDefaultButtonResult(Buttons) ' Determine which button "clicks" if timeout occurs
    mTimedMsgTitle = vbNullString
    
    Dim EvalString As String
    Dim EscPrompt As String
    Dim EscTitle As String
    Dim EscHelp As String
    Dim r As VbMsgBoxResult
    Dim tID As LongPtr
    
    ' Set default title if none provided
    If Title = "" Then Title = GetAppTitle
    
    ' Escape double quotes for the Eval() function to prevent syntax errors
    EscPrompt = Replace(Prompt, """", """""")
    EscTitle = Replace(Title, """", """""")
    EscHelp = Replace(HelpFile, """", """""")
    
    mTimedMsgTitle = Title
    
    ' === Start countdown if needed ===
    If Timeout > 0 Then
        StartCountdownWindow Timeout / 1000 ' Converts milliseconds to seconds
    End If
      
    ' Build and show the MsgBox using Eval.
    ' This allows the code to continue execution to the next line while MsgBox is open.
    If Context < 0 Then
        EvalString = "MsgBox(""" & EscPrompt & """, " & CLng(Buttons) & ", """ & EscTitle & """)"
    Else
        EvalString = "MsgBox(""" & EscPrompt & """, " & CLng(Buttons) & ", """ & EscTitle & """, """ & EscHelp & """," & CLng(Context) & ")"
    End If

    r = Eval(EvalString)
       
    ' Cleanup UI components after MsgBox is closed by user or timer
    If Timeout > 0 And Countdown = True Then
        CleanupCountdown
    End If
   
    ' Kill any leftover timer (original safety)
    If tID <> 0 Then KillTimer 0, tID
    
    ' Return the result: If timer closed it, use the default. If user clicked it, use their result.
    If mTimerFired Then
        TempVars!Timeout = "Yes"
        MsgBoxTC = mTimedResult
    Else
        TempVars!Timeout = "No"
        MsgBoxTC = r
    End If
End Function

'===========================
' Initialize and create the small floating countdown window
'===========================
Private Sub StartCountdownWindow(ByVal Seconds As Long)

    If TempVars!Countdown = True Then
        'show countdown text
         RemainingSeconds = Seconds
         mInitialSeconds = Seconds - 1 ' Store the total time for the progress bar calculation
         
         Dim dwExStyle As Long, dwStyle As Long
        
         ' WS_EX_LAYERED allows for the transparency effect
         dwExStyle = WS_EX_LAYERED
         dwStyle = WS_POPUP Or WS_VISIBLE Or SS_CENTER Or SS_CENTERIMAGE
        
         'CR - modified width, height values (previously 130, 20)
         hMainWnd = CreateWindowEx(dwExStyle, "Static", vbNullString, dwStyle, 0, 0, 160, 22, 0, 0, 0, ByVal 0&)
         If hMainWnd = 0 Then
             Debug.Print "Failed to create countdown window"
             Exit Sub
         End If
        
         ' Apply the transparency level defined in mTransparency
         SetLayeredWindowAttributes hMainWnd, 0, mTransparency, LWA_ALPHA
         ' CR - then hide the window at first - needed to overlay title for old style / standard messages
         ShowWindow hMainWnd, SW_HIDE
        
         ' Subclassing: Divert the window's messages to our custom "WindowProc" function
         #If Win64 Then
             OldWndProc = SetWindowLongPtr(hMainWnd, GWL_WNDPROC, AddressOf WindowProc)
         #Else
             OldWndProc = SetWindowLong(hMainWnd, GWL_WNDPROC, AddressOf WindowProc)
         #End If
        
         ' Set a 1-second system timer to trigger the CountdownTimerProc
        SetTimer hMainWnd, 1, 1000, AddressOf CountdownTimerProc
        
    Else
        'CR - just run timeout with no countdown
        SetTimer hMainWnd, 1, TempVars!Timeout, AddressOf CountdownTimerProc
    
    End If
   
   
End Sub

'===========================
' Custom Window Procedure:
' Handles drawing the text and background of the countdown window
'===========================
Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  
    If hwnd = hMainWnd Then
        
        Select Case uMsg
            
            Case WM_ERASEBKGND
                ' Allow default erase or force a clear
                WindowProc = 1   ' Tell Windows we handled it (prevents flicker in some cases)
                Exit Function
            Case WM_PAINT
                Dim ps As PAINTSTRUCT: Dim hdc As LongPtr: Dim r As RECT
                Dim rBar As RECT: Dim sText As String: Dim hBrush As LongPtr
                Dim barWidth As Long
                
                hdc = BeginPaint(hwnd, ps)
                GetClientRect hwnd, r
                ' === CRITICAL: Clear the entire area with a solid brush first ===
                ' This removes ALL previous text pixels to prevent "ghosting" as numbers change
                ' 1. Clear Background
                hBrush = CreateSolidBrush(mBackGroundColor)
                FillRect hdc, r, hBrush
                DeleteObject hBrush
                
                ' 2. Draw Progress Bar at the bottom
                ' Calculate width based on time remaining
                If mInitialSeconds > 0 Then
                    barWidth = (r.Right - r.Left) * (RemainingSeconds / mInitialSeconds)
                End If
                
                ' Define the bar rectangle (bottom 2 pixels)
                rBar.Left = r.Left
                rBar.Top = r.Bottom - 2
                rBar.Right = r.Left + barWidth
                rBar.Bottom = r.Bottom
                ' Draw the bar (using your text color for consistency)
                If mProgressBar Then
                    hBrush = CreateSolidBrush(mTextColor)
                    FillRect hdc, rBar, hBrush
                    DeleteObject hBrush
                End If
                
                
                ' 3. Draw Text (Adjusted slightly up to not overlap the bar)
                SetBkMode hdc, TRANSPARENT
                SetTextColor hdc, mTextColor
                sText = "Time Remaining: " & RemainingSeconds & "s"
                If mProgressBar Then
                    ' Move the text rectangle up by 2 pixels so it looks centered above the bar
                    r.Bottom = r.Bottom - 2
                End If
               
               ' DrawText hdc, sText, -1, r, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
               'CR - changed to left aligned
                DrawText hdc, sText, -1, r, DT_LEFT  'CR
                
                Exit Function
                
        End Select
    End If
  
  ' CR - I think this is for when countdown window no longer exists (or is never used)
   ' Pass all other messages to the original window procedure
    WindowProc = CallWindowProc(OldWndProc, hwnd, uMsg, wParam, lParam)

End Function

'===========================
' Force countdown window to stay on top AFTER MsgBox appears
' Repositions the countdown window relative to the Message Box
'===========================
Private Sub BringCountdownToTop()
    Dim hMsg As LongPtr
    Dim tRect As RECT, cRect As RECT
    Dim newX As Long, newY As Long
    Dim msgWidth As Long, msgHeight As Long
    Dim winWidth As Long, winHeight As Long
    
    If hMainWnd = 0 Then Exit Sub
    
    hMsg = FindWindowW(StrPtr(vbNullString), StrPtr(mTimedMsgTitle))
    
    If hMsg <> 0 Then
        GetWindowRect hMsg, tRect
        GetWindowRect hMainWnd, cRect ' Get countdown window size
        
        msgWidth = tRect.Right - tRect.Left
        msgHeight = tRect.Bottom - tRect.Top
        winWidth = cRect.Right - cRect.Left
        winHeight = cRect.Bottom - cRect.Top
        
        Select Case mPosMode
            Case PosTopLeft
                newX = tRect.Left + mOffsetLeft
                newY = tRect.Top + mOffsetTop
            Case PosTopRight
                newX = tRect.Right - winWidth - mOffsetLeft - 20
                newY = tRect.Top + mOffsetTop
            Case PosBottomLeft
                newX = tRect.Left + mOffsetLeft
                newY = tRect.Bottom - winHeight - mOffsetTop - 10 ' Small buffer for shadow
            Case PosBottomRight
                newX = tRect.Right - winWidth - mOffsetLeft
                newY = tRect.Bottom - winHeight - mOffsetTop - 10
            Case PosCenter
                newX = tRect.Left + (msgWidth / 2) - (winWidth / 2)
                newY = tRect.Top + (msgHeight / 2) - (winHeight / 2)
            Case PosTopCenter
                newX = tRect.Left + (msgWidth / 2) - (winWidth / 2)
                newY = tRect.Top + mOffsetTop
            Case PosbottomCenter
                newX = tRect.Left + (msgWidth / 2) - (winWidth / 2)
                newY = tRect.Bottom - winHeight - mOffsetTop - 10
        End Select

        SetWindowPos hMainWnd, HWND_TOPMOST, newX, newY, 0, 0, _
                     SWP_NOSIZE Or SWP_NOACTIVATE Or SWP_SHOWWINDOW
    End If
End Sub

'===========================
' Timer callback for countdown
' Triggered every 1000ms by the system timer
'===========================
Public Sub CountdownTimerProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                              ByVal idEvent As LongPtr, ByVal dwTime As Long)
    
    RemainingSeconds = RemainingSeconds - 1
    
    ' Ensure the countdown window stays positioned correctly over the MsgBox
    Call BringCountdownToTop
    
    If RemainingSeconds <= 0 Then
        ' Timeout reached -> close both windows
        mTimerFired = True
        CloseMsgBoxAndCountdown
        CleanupCountdown
    Else
        ' Refresh the display text
        UpdateCountdownLabel
    End If
End Sub

'===========================
' Triggers a repaint of the countdown window
'===========================

Private Sub UpdateCountdownLabel()
    If hMainWnd <> 0 Then
        ' bErase = True is very important here
        InvalidateRect hMainWnd, ByVal 0&, 1
    End If
End Sub

'===========================
' Close both the MsgBox and the countdown window
' Sends a close command to the standard message box
'===========================
Private Sub CloseMsgBoxAndCountdown()
    Dim hMsg As LongPtr
    hMsg = FindWindowW(StrPtr(vbNullString), StrPtr(mTimedMsgTitle))
    
    If hMsg <> 0 Then
        ' Sends WM_CLOSE to the MsgBox window handle
        PostMessageW hMsg, WM_CLOSE, 0, 0
    End If
End Sub

'===========================
' Cleanup the countdown window and font
' Reverses subclassing and releases memory/GDI objects
'===========================
Private Sub CleanupCountdown()

    ' Remove subclassing first to prevent Access from crashing on close
    If hMainWnd <> 0 And OldWndProc <> 0 Then
        #If Win64 Then
            SetWindowLongPtr hMainWnd, GWL_WNDPROC, OldWndProc
        #Else
            SetWindowLong hMainWnd, GWL_WNDPROC, OldWndProc
        #End If
        OldWndProc = 0
    End If

    ' Kill the timer and destroy the window handle
    If hMainWnd <> 0 Then
        KillTimer hMainWnd, 1
        DestroyWindow hMainWnd
        hMainWnd = 0
    End If

End Sub

'===========================
' Determine default button result
' This logic maps the VbMsgBoxStyle bits to the correct result if a timeout occurs
'===========================
Function GetDefaultButtonResult(Buttons As VbMsgBoxStyle) As VbMsgBoxResult
    Dim defBtn As Long
    defBtn = Buttons And &H300 ' mask default button bits (vbDefaultButton1, 2, or 3)
        
    Select Case Buttons And &HF ' Extract the button group (OK, YesNo, etc.)
        Case vbOKOnly
            GetDefaultButtonResult = vbOK

        Case vbOKCancel
            If defBtn = vbDefaultButton2 Then
                GetDefaultButtonResult = vbCancel
            Else
                GetDefaultButtonResult = vbOK
            End If

        Case vbYesNo
            If defBtn = vbDefaultButton2 Then
                GetDefaultButtonResult = vbNo
            Else
                GetDefaultButtonResult = vbYes
            End If

        Case vbYesNoCancel
            Select Case defBtn
                Case vbDefaultButton2: GetDefaultButtonResult = vbNo
                Case vbDefaultButton3: GetDefaultButtonResult = vbCancel
                Case Else:             GetDefaultButtonResult = vbYes
            End Select

        Case vbRetryCancel
            If defBtn = vbDefaultButton2 Then
                GetDefaultButtonResult = vbCancel
            Else
                GetDefaultButtonResult = vbRetry
            End If

        Case vbAbortRetryIgnore
            Select Case defBtn
                Case vbDefaultButton2: GetDefaultButtonResult = vbRetry
                Case vbDefaultButton3: GetDefaultButtonResult = vbIgnore
                Case Else:             GetDefaultButtonResult = vbAbort
            End Select

        Case Else
            GetDefaultButtonResult = vbOK
    End Select
End Function

'===========================
' Helper Function to set default title if blank
' Attempts to pull the "AppTitle" from Access database properties
'===========================
Public Function GetAppTitle() As String
    Dim Db As DAO.Database, prp As Property
    
    On Error GoTo Err_Handler
   
    Set Db = CurrentDb
    GetAppTitle = Db.Properties("AppTitle")

Exit_Handler:
   Exit Function

Err_Handler:
    Select Case Err.Number
    Case 3270 'Property Not Found
        ' If no AppTitle property is set, fallback to default
        GetAppTitle = "Microsoft Access"
    Case Else
        VBA.MsgBox "Error " & Err.Number & " " & Err.Description & " in procedure GetAppTitle", vbCritical, "GetAppTitle error"
        
    End Select
    
    Resume Exit_Handler

End Function

'===========================
' Set colour for text & background of countdown overlay window based on Office theme
'===========================

' Office theme registry values:
'   3 = Dark Grey
'   4 = Black
'   5 = White
'   6 = Use System Settings
'   7 = Colorful

' Windows AppsUseLightTheme values:
'   0 = Dark Mode
'   1 = Light Mode

' ============================================================

Public Function GetCurrentOfficeTheme() As Long

    Dim regTheme As Variant
    regTheme = ReadReg("HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Common\UI Theme")

    Select Case regTheme

    Case 0
        GetCurrentOfficeTheme = 7 'default is Colorful
    Case 6 'use system settings
        GetCurrentOfficeTheme = ResolveSystemTheme()
    Case Else '3,4,5,7
        GetCurrentOfficeTheme = CLng(regTheme)

    End Select

End Function

Private Function ResolveSystemTheme() As String
    Dim winMode As Variant
    winMode = ReadReg("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Themes\Personalize\AppsUseLightTheme")

    If IsNull(winMode) Then
        ResolveSystemTheme = 7 'Colourful   ' Office default fallback
        Exit Function
    End If

    If CLng(winMode) = 0 Then
        ResolveSystemTheme = 4 'Black      ' Windows Dark Mode => Office Black
    Else
        ResolveSystemTheme = 7 'Colourful   ' Windows Light Mode => Office Colorful
    End If
End Function

Private Function ReadReg(path As String) As Variant
    On Error Resume Next
    Dim wsh As Object
    Set wsh = CreateObject("WScript.Shell")
    ReadReg = wsh.RegRead(path)
End Function

Public Function SetCountDownWindowColors() As Long

    ' For Colorful / White Theme & Fluent UI: The title text is a Dark Redon a white background
    ' For Dark Gray / Black Theme & Fluent UI: The title text is white on a dark background
    ' For old style or standatd messages, themes aren't used: The title text is dark grey on an off-white background

    If TempVars!Context < 0 Then
            'Old style & standard messages are theme independent
            mTextColor = RGB(81, 81, 81) 'dark grey '
            mBackGroundColor = RGB(240, 240, 240) 'light grey 'RGB(255, 255, 255) 'white
    Else
        'Fluent UI messages
        Select Case GetCurrentOfficeTheme()
            Case 3 'dark grey
                mTextColor = RGB(240, 240, 240) 'light grey
                mBackGroundColor = RGB(81, 81, 81) 'dark gray
            
            Case 4 'black
                mTextColor = RGB(255, 255, 255)  'white
                mBackGroundColor = RGB(30, 30, 30) 'Very dark grey
            
            Case 5 'White
                mTextColor = RGB(175, 32, 49) 'dark red 'RGB(0, 0, 0) 'black
                mBackGroundColor = RGB(255, 255, 255) 'white
                
            Case 7 'colorful
                mTextColor = RGB(175, 32, 49) 'dark red
                mBackGroundColor = RGB(255, 255, 255) 'white
                
            Case Else
                mTextColor = RGB(81, 81, 81) 'dark grey
                mBackGroundColor = RGB(255, 255, 255)
        End Select
    
    End If
End Function

The module can be imported into any Access app without additional coding and can be used in place of the standard VBA MsgBox without breaking any existing code.

Some disadvantages are that it requires a large number of APIs and the overlay text position may need to be slightly modified for different monitors / resolutions.

3.   Use a custom message form

This is sometimes the easiest approach and allows for a wide range of message box styles. The short videos below show some possible solutions
NOTE: None of these videos have audio

a)   Custom form with a hyperlink from my Database Analyzer Pro app with the countdown displayed as part of the default button caption:

     

b)   Task Dialog message by Kevin Bell with a progress bar and a countdown message. This is included as part of my Attention Seeking Database example app.

     

c)   Maintenance warning form with a countdown message. This is also included as part of my Attention Seeking Database example app.

     

d)   Custom HTML Dialog message by Marcus Dieterle with additional functionality and the countdown displayed in the form header.
      Marcus demonstrated this as part of his presentation to the Access Europe User Group in Oct 2025: Custom Dialogs and Mini Notifications

     

These forms all are very different in style and the coding required for these varies significantly in complexity.

Creating a custom form which closely resembles a new style Fluent UI message box but with a timeout and countdown could be very complex. As a starting point, I would recommend reviewing the custom forms created by Neil Sargent that were demonstrated to the Access Europe User Group in Jan 2026: Spot the Difference - A new style MsgBox for Access



Downloads

Click to download an example app with all code and sample messages:     MsgBox Timeout Countdown v1.58      (ACCDB - Approx 0.9 MB zipped)

Alternatively, you can download just the module code and import it into your own apps:     modTimedMsgBoxCountdown     .bas (zipped)

As is the case for all files downloaded from the internet, first unblock the downloaded file, unzip then save to a trusted location.
For more details, see my article: Unblock downloaded files by removing the Mark of the Web



Further Reading

Please see these related message box articles elsewhere on this website:

    New Style Access Message Boxes With Timeout

    New Style Message Box: Part 1 - Using Wizhook

    New Style Message Box: Part 2 - Using Eval

    Formatted Message Box

    PUZZLE: Access Message Boxes with no VBA code

    Customize the Appearance of the Access MsgBox

    Add a Timeout to Message Boxes

    Create Messages using the Access Expression Service

    Message Box Constants & Values



Feedback

Please use the E-Mail button in the contact form below to let me know whether you found this article useful or if you have any questions.

Please also consider making a donation towards the costs of maintaining this website. Thank you

Colin Riddington	Mendip Data Systems	Last Updated 16 Apr 2026

Return to Code Samples Page

Return to Top