Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- 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:
2- Code Usage example:
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 Function2- 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
