Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,313
Office Version
  1. 2016
Platform
  1. Windows
Hi,

I have been playing around with this in order to make this kind of plug-and-play timed popup, entirely based on the standard vba MsgBox after having manipulated it with some API calls... A good alternative for the buggy Shell popup.

The popup has some cool features such as an optional ticking countdown sound, optional Topmost, fading away upon closing plus some pretty animation to draw the user's attention.

One limitation though is the fact that you can't use the default MsgBox icons (Information, Exclamation, Question and Warning icons) . This is due to the window banner stretching accross the top hence taking up the required space for the icons.

In case you need the return value of the MsgBox (so you can act accordingly), the second argument (ByRef TimedOutRet) returns -1 indicating that the MsgBox timed out ( ie:= was not closed by the user) or 0 otherwise.

The code is quite extensive because the wav-sound bytes as well as the bytes of the animated clock icon are all self-contained inside the BAS module so that the bytes can be extracted to memory on the fly ... I have done this for portability reasons (kind of like a having a seperate resource file but all included in the workbook)

Demo File
TimedVBAMsgBox.xlsm


Here is a Preview:







IMPORTANT NOTE: I am not posting the entire code here as it is too large and exceeds the number of characters permitted in the forum... The following code has been trimmed and I have taken away the large section corresponding to the sound and icon bytes... So, in order to obtain the entire code, please download the demo file from the link above.




1- API code in a Standard Module:
VBA Code:
'Code by Jaafar Tribak on 12/04/2021 @ MrExcel.Com.
'Your Typical Standard VBA MsgBox API-Abused to coarce it into
'behaving like a TimeOut PopUp + some added cool formatting & Animation.

Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

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

Private Type PAINTSTRUCT
    #If Win64 Then
        hdc As LongLong
    #Else
        hdc As Long
    #End If
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(0 To 31) As Byte
End Type

Private Type TRIVERTEX
    X As Long
    Y As Long
    Red As Integer
    Green As Integer
    Blue As Integer
    Alpha As Integer
End Type

Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    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
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowPos Lib "user32.dll" (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 wFlags As Long) As Long
    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
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    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
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hdc As LongPtr, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
    Private Declare PtrSafe Function DrawIcon Lib "user32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As LongPtr
    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
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (lpszSoundName As Any, ByVal uFlags As Long) As Long
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
    Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
    Private Declare PtrSafe Function GetCapture Lib "user32" () As LongPtr
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long

    Private hHook As LongPtr, lPrevStaticProc As LongPtr, hNewStatic As LongPtr, hMsgBox As LongPtr
    Private lngIconArray(12) As LongPtr, lCurIcon As LongPtr, hBrush As LongPtr, lStartTime As LongPtr
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare 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 Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
    Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
    Private Declare Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal Flags As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (lpszSoundName As Any, ByVal uFlags As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
    Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseCapture Lib "user32" () As Long
    Private Declare Function GetCapture Lib "user32" () As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long

    Private hHook As Long, lPrevStaticProc As Long, hNewStatic As Long, hMsgBox As Long
    Private lngIconArray(12) As Long, lCurIcon As Long, hBrush As Long, lStartTime As Long
#End If

#If Win64 Then
    Const VARIANT_OFFSET_FACTOR = 24
#Else
    Const VARIANT_OFFSET_FACTOR = 16
#End If

Private vTempSoundArray() As Variant
Private SoundBytesArray() As Byte
Private bClockTickingSound As Boolean, bTopMost As Boolean, dTimeOut As Date
Private lTimeOutRet As Long
Private lIconCounter As Long
Private bSoundCreated As Boolean
Private lShadowStartPos As Long, bNewRound As Boolean


  
  
Public Function TimedMsgBox( _
        ByVal Prompt As String, _
        ByVal TimeOut As Date, _
        ByRef TimedOutRet As Long, _
        Optional ByVal Buttons As VbMsgBoxStyle, _
        Optional ByVal Title As String, _
        Optional ByVal ClockTickingSound As Boolean, _
        Optional ByVal TopMost As Boolean _
    ) As VbMsgBoxResult


    Const WH_CBT = 5
    Dim lButtonsStyle As Long
    Dim lExcludeButtons As VbMsgBoxStyle
  
    bClockTickingSound = ClockTickingSound
    bTopMost = TopMost
    dTimeOut = TimeOut
    bSoundCreated = False
    lTimeOutRet = 0
  
    If Len(Title) <= 10 Then Title = Title + Space(50 - Len(Title))
  
    lExcludeButtons = vbApplicationModal Or vbCritical Or vbExclamation Or vbInformation _
    Or vbMsgBoxRight Or vbMsgBoxRtlReading Or vbMsgBoxSetForeground Or vbQuestion Or vbSystemModal
  
    lButtonsStyle = Buttons And Not lExcludeButtons
  
     hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
  
    TimedMsgBox = MsgBox(Prompt, lButtonsStyle, IIf(Len(Title), Title, "Microsoft Excel"))
  
    TimedOutRet = lTimeOutRet

End Function





'_____________________________________PRIVATE ROUTINES__________________________________________

#If Win64 Then
    Private Function HookProc(ByVal lCode As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
        Dim hStatic As LongLong, hFont As LongLong
#Else
    Private Function HookProc(ByVal lCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim hStatic As Long, hFont As Long
#End If

    Const GWL_WNDPROC = -4
    Const HC_ACTION = 0
    Const HCBT_CREATEWND = 3
    Const HCBT_ACTIVATE = 5
    Const WS_CHILD = &H40000000
    Const WS_VISIBLE = &H10000000
    Const WS_BORDER = &H800000
    Const WM_GETFONT = &H31
    Const WM_SETFONT = &H30
    Const SWP_NOMOVE = &H2
    Const SWP_NOSIZE = &H1
    Const SWP_SHOWWINDOW = &H40
    Const SND_LOOP = &H8
    Const SND_ASYNC = &H1
    Const SND_NODEFAULT = &H2
    Const SND_MEMORY = &H4
    Const ICON_HEIGHT = 32
  
    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim tMsgBoxRect As RECT, tStaticRect As RECT
    Dim sClassName As String * 256, lRet As Long
    Dim lEditStyles As Long


    If lCode < HC_ACTION Then
        HookProc = CallNextHookEx(hHook, lCode, wParam, lParam)
        Exit Function
    End If
  
    If lCode = HCBT_CREATEWND Then
        lRet = GetClassName(wParam, sClassName, 256)
        If Left$(sClassName, lRet) = "#32770" Then
            If bClockTickingSound Then
                bSoundCreated = False
                Call CreateWavSound
            End If
        End If
    End If

    If lCode = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sClassName, 256)
        If Left$(sClassName, lRet) = "#32770" Then
            Call UnhookWindowsHookEx(hHook)
            hMsgBox = wParam
            If bTopMost Then
                Call SetWindowPos(hMsgBox, -1, 0, 0, 0, 0, SWP_SHOWWINDOW + SWP_NOSIZE + SWP_NOMOVE)
                Call SetActiveWindow(Application.hwnd)
            End If
            Call DestroyWindow(GetDlgItem(hMsgBox, &H14))
            Call GetClientRect(hMsgBox, tMsgBoxRect)
            hStatic = GetDlgItem(hMsgBox, &HFFFF&)
            Call GetWindowRect(hStatic, tStaticRect)
            With tStaticRect
                p1.X = .Left: p1.Y = .Top
                p2.X = .Right: p2.Y = .Bottom
                Call ScreenToClient(hMsgBox, p1)
                Call ScreenToClient(hMsgBox, p2)
                .Left = p1.X: .Top = p1.Y
                .Right = p2.X: .Bottom = p2.Y
            End With
            With tStaticRect
                Call SetWindowPos(hStatic, 0, .Left, .Top + 20, 0, 0, SWP_SHOWWINDOW + SWP_NOSIZE)
            End With
            lEditStyles = WS_CHILD + WS_VISIBLE + WS_BORDER
            With tStaticRect
                hNewStatic = CreateWindowEx(0, "STATIC", vbNullString, lEditStyles, _
                0, tMsgBoxRect.Top, tMsgBoxRect.Right - tMsgBoxRect.Left, ICON_HEIGHT + 4, hMsgBox, 0, GetModuleHandle(vbNullString), 0)
            End With
            If hNewStatic Then
                hFont = SendMessage(hStatic, WM_GETFONT, 0, 0)
                Call SendMessage(hNewStatic, WM_SETFONT, hFont, True)
                Call CreateIcons
                If SafeArrayGetDim(SoundBytesArray) Then
                    Call PlaySound(SoundBytesArray(0), SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY Or SND_LOOP)
                End If
                Call KillTimer(hMsgBox, 0)
                lStartTime = GetTickCount
                Call SetTimer(hMsgBox, 0, 0, AddressOf UpdateScreen)
                hBrush = CreateSolidBrush(RGB(180, 0, 0))
                lPrevStaticProc = SetWindowLong(hNewStatic, GWL_WNDPROC, AddressOf NewStaticProc)
            End If
        End If
    End If

    Call CallNextHookEx(hHook, lCode, wParam, lParam)

End Function


#If Win64 Then
    Private Function NewStaticProc(ByVal hwnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
    Private Function NewStaticProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Const GWL_WNDPROC = -4
    Const WM_PAINT = &HF
    Const WM_DESTROY = &H2
    Const WM_SYSCOMMAND = &H112
    Const SC_CLOSE = &HF060&
    Const BM_CLICK = &HF5&
    Const TRANSPARENT = 1
    Const DT_VCENTER = &H4
    Const DT_CENTER = &H1
    Const DT_CALCRECT = &H400
    Const GRADIENT_FILL_RECT_H = &H0
    Const ICON_WIDTH = 32
    Const ICON_HEIGHT = 32
    Const SHADOW_WIDTH = 50

    Dim tPS As PAINTSTRUCT
    Dim vert(2) As TRIVERTEX, tPt As GRADIENT_RECT
    Dim R As Byte, G As Byte, B As Byte
    Dim p1 As POINTAPI, p2 As POINTAPI, tWinRect As RECT, tClientRect As RECT, tTextRect As RECT, tBrushRect As RECT
    Dim sTimeLeft As String, sCountdownText As String


    Select Case Msg
        Case WM_PAINT
            Call BeginPaint(hwnd, tPS)
                Call GetWindowRect(hwnd, tWinRect)
                Call ConvertLongToRGB(vbRed, R, G, B)
                Call SetRect(tBrushRect, 0, 0, tWinRect.Right - tWinRect.Left, ICON_HEIGHT + 4)
                Call FillRect(tPS.hdc, tBrushRect, hBrush)
                With vert(0)
                    .X = lShadowStartPos
                    .Y = 0
                    .Red = TransCol(0)
                    .Green = TransCol(0)
                    .Blue = TransCol(0)
                    .Alpha = 0
                End With
                With vert(1)
                    .X = lShadowStartPos + SHADOW_WIDTH
                    .Y = tWinRect.Bottom - tWinRect.Top
                    .Red = TransCol(RGB(180, 0, 0))
                    .Green = TransCol(0)
                    .Blue = TransCol(0)
                    .Alpha = 0
                End With
                tPt.UpperLeft = 0
                tPt.LowerRight = 1
                Call GradientFillRect(tPS.hdc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H)
                With vert(0)
                    .X = lShadowStartPos
                    .Y = 0
                    .Red = TransCol(0)
                    .Green = TransCol(0)
                    .Blue = TransCol(0)
                    .Alpha = 0
                End With
                With vert(1)
                    .X = lShadowStartPos - SHADOW_WIDTH
                    .Y = tWinRect.Bottom - tWinRect.Top
                    .Red = TransCol(RGB(180, 0, 0))
                    .Green = TransCol(0)
                    .Blue = TransCol(0)
                    .Alpha = 0
                End With
                tPt.UpperLeft = 0
                tPt.LowerRight = 1
                Call GradientFillRect(tPS.hdc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H)
                If lShadowStartPos >= (tWinRect.Right - tWinRect.Left) Then bNewRound = True
                Call SetBkMode(tPS.hdc, TRANSPARENT)
                Call SetTextColor(tPS.hdc, vbWhite)
                With tWinRect
                     p1.X = .Left: p1.Y = .Top + 3
                    p2.X = .Right: p2.Y = .Bottom
                    Call ScreenToClient(hwnd, p1)
                    Call ScreenToClient(hwnd, p2)
                    tClientRect.Left = p1.X + ICON_WIDTH: tClientRect.Top = p1.Y
                    tClientRect.Right = p2.X: tClientRect.Bottom = p2.Y
                End With
                sTimeLeft = CStr(dTimeOut - Now)
                sTimeLeft = Format(sTimeLeft, "hh:mm:ss")
                sCountdownText = "COUNTDOWN" & vbCrLf & Format(sTimeLeft, "hh:mm:ss")
                Call DrawText(tPS.hdc, sCountdownText, Len(sCountdownText), tClientRect, DT_VCENTER + DT_CENTER)
                Call DrawText(tPS.hdc, sCountdownText, Len(sCountdownText), tTextRect, DT_CALCRECT)
                Call DrawIcon(tPS.hdc, (tClientRect.Right - tClientRect.Left) / 2 - (tTextRect.Right / 2) - ICON_WIDTH / 4, tClientRect.Top, lCurIcon)
                lTimeOutRet = 0
                If sTimeLeft = "00:00:00" Then
                    lTimeOutRet = -1
                    Call KillTimer(Application.hwnd, 0)
                    Call SetTimer(Application.hwnd, hMsgBox, 0, AddressOf FadeAway)
                End If
            Call EndPaint(hwnd, tPS)
        Case WM_DESTROY
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevStaticProc)
            Call KillTimer(hMsgBox, 0)
            Call KillTimer(Application.hwnd, 0)
            Call StopSound
            Call DeleteObject(hBrush)
            bClockTickingSound = False
            bTopMost = False
            lShadowStartPos = 0
            bNewRound = False
            lIconCounter = 0
            Call DeleteIcons
    End Select
  
    NewStaticProc = CallWindowProc(lPrevStaticProc, hwnd, Msg, wParam, ByVal lParam)

End Function


#If Win64 Then
    Private Sub FadeAway(ByVal hwnd As LongLong, _
        ByVal uMsg As Long, _
        ByVal idEvent As LongLong, _
        ByVal dwTime As Long)
#Else
    Private Sub FadeAway(ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal idEvent As Long, _
        ByVal dwTime As Long)
#End If

    Const WM_SYSCOMMAND = &H112
    Const SC_CLOSE = &HF060&
    Const BM_CLICK = &HF5&
    Const GWL_EXSTYLE = (-20)
    Const WS_EX_LAYERED = &H80000
    Const LWA_ALPHA = &H2&
  
    Static lAlpha As Long
  
    If lAlpha = 0 Then
        Call SetWindowLong(idEvent, GWL_EXSTYLE, (GetWindowLong(idEvent, GWL_EXSTYLE) Or WS_EX_LAYERED))
    End If
    Call SetLayeredWindowAttributes(idEvent, 0, 255 - (lAlpha * 5), LWA_ALPHA)
    Call UpdateWindow(idEvent)
    If 255 - (lAlpha * 5) <= 0 Then
        Call KillTimer(Application.hwnd, idEvent)
        lAlpha = 0
        If GetCapture = idEvent Then
            Call ReleaseCapture
        End If
        Call SendMessage(GetDlgItem(idEvent, &H3), BM_CLICK, 0, 0)
        Call SendMessage(idEvent, WM_SYSCOMMAND, SC_CLOSE, ByVal 0)
        Exit Sub
    End If
    lAlpha = lAlpha + 1

End Sub

Private Sub StopSound()
    If SafeArrayGetDim(SoundBytesArray) Then
        Call PlaySound(ByVal StrPtr(vbNullString), 0)
        Erase SoundBytesArray
    End If
End Sub

Private Sub UpdateScreen()

    Const NUMBER_OF_ICON_FRAMES = 12
    Const SHADOW_WIDTH = 50
    Static lTimePassed As Long
  
    On Error Resume Next
    Call KillTimer(hMsgBox, 0)
    Call SetTimer(hMsgBox, 0, 0, AddressOf UpdateScreen)
    If lIconCounter = NUMBER_OF_ICON_FRAMES + 1 Then lIconCounter = 0
    If Int((GetTickCount - lStartTime) / 1000) <> lTimePassed Or lIconCounter = 0 Then
        Call InvalidateRect(hNewStatic, 0, 0)
        lStartTime = GetTickCount
        lIconCounter = lIconCounter + 1
        lCurIcon = lngIconArray(lIconCounter)
    End If
    lTimePassed = Int((GetTickCount - lStartTime) / 1000)
    If bNewRound Then
        bNewRound = False
        lShadowStartPos = -SHADOW_WIDTH
    Else
        lShadowStartPos = lShadowStartPos + 1
    End If

End Sub

Private Sub CreateIcons()
    #If Win64 Then
        Dim lIcon As LongLong
    #Else
        Dim lIcon As Long
    #End If
  
    Const NUMBER_OF_ICON_FRAMES = 12

    Dim i As Long
    For i = 1 To NUMBER_OF_ICON_FRAMES
        lIcon = Application.Run("Icon" & i)
        lngIconArray(i) = lIcon
    Next i
  
End Sub

Private Sub DeleteIcons()

    Const NUMBER_OF_ICON_FRAMES = 12
    Dim i As Long
    On Error Resume Next
    For i = 1 To NUMBER_OF_ICON_FRAMES
        Call DestroyIcon(lngIconArray(i))
    Next i
    Erase lngIconArray
End Sub

Private Sub CreateWavSound()
    Call BuildSound
End Sub


Private Sub ConvertLongToRGB(ByVal Value As Long, R As Byte, G As Byte, B As Byte)
    R = Value Mod 256
    G = Int(Value / 256) Mod 256
    B = Int(Value / 256 / 256) Mod 256
End Sub

Private Function TransCol(ByVal Col As Long) As Double
    Dim a As Double
    If Col = 0 Then
        TransCol = 0
    ElseIf Col > 127 Then
        a = 256 - Col
        TransCol = -(256 * a)
    Else
        a = Col
        TransCol = 256 * a
    End If
End Function




2- Code Usage example:
VBA Code:
Option Explicit

Sub Test()

    Dim lTimeOutRet As Long
    Dim lRet As VbMsgBoxResult
    Dim sPrompt As String
  
    sPrompt = "WARNING" & vbCrLf & vbCrLf & "You are being timed out due to inactivity." & vbCrLf & vbCrLf & _
        "Please, click the (OK) button to acknowledge that you are still working." & _
        " Otherwise, you will automatically be signed out seconds from now."
  
    lRet = TimedMsgBox( _
            Prompt:=sPrompt, _
            TimeOut:=Now + TimeSerial(0, 0, 30), _
            TimedOutRet:=lTimeOutRet, _
            Title:="Time-Out VBA MsgBox", _
            ClockTickingSound:=True, _
            TopMost:=True)
  
    If lTimeOutRet = -1 Then
        MsgBox "Timed Out"
    Else
        'Closed by the user
        MsgBox "Ok- You are still there :)"
    End If

End Sub
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,624
Office Version
  1. 2016
Platform
  1. Windows
Very large code for a short message but I'm buying 👍
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,313
Office Version
  1. 2016
Platform
  1. Windows
Very large code for a short message but I'm buying 👍
Hi Zot,

Thanks for the feedback.

The large code was due to the extracted wav sound and icon file bytes but this makes the timeout msgbox portable and self-contained without any dependencies... Just plug it to your vba project and play.

BTW, did you download the demo workbook to test the code ? and if so, did the msgbox work as expected ?

I am asking because I recived a PM from a forum member earlier on, who stated that the height of the top red banner accross the top was too small for housing the entire COUNTDOWN text and ticking clock icon.

Can you let me know ? THANKS.
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,624
Office Version
  1. 2016
Platform
  1. Windows
Hi Zot,

Thanks for the feedback.

The large code was due to the extracted wav sound and icon file bytes but this makes the timeout msgbox portable and self-contained without any dependencies... Just plug it to your vba project and play.

BTW, did you download the demo workbook to test the code ? and if so, did the msgbox work as expected ?

I am asking because I recived a PM from a forum member earlier on, who stated that the height of the top red banner accross the top was too small for housing the entire COUNTDOWN text and ticking clock icon.

Can you let me know ? THANKS.
It works as shown in your demo. The red banner height is just fine and so the clock.
Like you I'm on Excel 2016.
Desktop with 1680 x 1050 resolution.
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,313
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

It works as shown in your demo. The red banner height is just fine and so the clock.
Like you I'm on Excel 2016.
Desktop with 1680 x 1050 resolution.
Good! (y)

The problem was reported in excel 365.

I have made a couple of small amendements to the code in order to fix the reported issue and sent the update to the user experiencing this issue.

I will be waiting for his feedback and if that fixes the problem, I post the update here .

Thanks for letting me know that it worked ok for you.
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
599
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hi Jaafar. Thank you for this. It works flawlessly - it looks a lot like a TaskDialog, but better. (Win10 / 365 / 64bit).
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,313
Office Version
  1. 2016
Platform
  1. Windows
Hi Jaafar. Thank you for this. It works flawlessly - it looks a lot like a TaskDialog, but better. (Win10 / 365 / 64bit).
Yes. In fact, I was inspired to write this cutomised MsgBox after looking at some taskdialogs.

Thank you for your feedback on this and glad it worked flawlessly.
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
599
Office Version
  1. 365
Platform
  1. Windows
It's great.
I take it you've seen the TaskDialog class that fafalone wrote (link), and that was converted into 64-bit (thankfully) by AccessUI (link)?
I've been adapting it to Excel, and I'm really happy with it - the functionality is really impressive. I'm a little surprised that it isn't spoken about more often. Is there some reason it shouldn't be used?
Thanks again.
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,313
Office Version
  1. 2016
Platform
  1. Windows
It's great.
I take it you've seen the TaskDialog class that fafalone wrote (link), and that was converted into 64-bit (thankfully) by AccessUI (link)?
I've been adapting it to Excel, and I'm really happy with it - the functionality is really impressive. I'm a little surprised that it isn't spoken about more often. Is there some reason it shouldn't be used?
Thanks again.
No. thety are two different animals.

Fafalone's code uses the TaskDialogIndirect supported in vista and higher. Whereas the code I have used here, is entirely based on the standard vba MsgBox.

The only ressemblance between the two is perhaps the red cross band that spans across the top of the window.
 

Forum statistics

Threads
1,141,772
Messages
5,708,447
Members
421,570
Latest member
BaileyJ

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top