Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi dear forum,
Got bored and decided to add some animation to the standard vba MsgBox. It is not going to be of much use to most excel\vba users, but it was fun to code and will add to the MsgBox, some lively aspect that can be used in capturing the user's attention.
Basically, the code simply hijacks the MsgBox and replaces its default icon with the gif of your choice.
Workbook example:
AnimatedMsgBox.xlsm
I am not versed with HTML DOM coding ... In the tests I carried out with various gifs, I could successfully set the backgroundcolor only in some of them. This is in order to match the gif background color with the MsgBox theme for blending.
Unless the gif is a transparent gif, much of the image quality may be affected if the gif has a background color that cannot be set.
1- API code in a Standard Module:
2- Test (as per the workbook demo)
Gifs can be added from disk files or from urls.
Got bored and decided to add some animation to the standard vba MsgBox. It is not going to be of much use to most excel\vba users, but it was fun to code and will add to the MsgBox, some lively aspect that can be used in capturing the user's attention.
Basically, the code simply hijacks the MsgBox and replaces its default icon with the gif of your choice.
Workbook example:
AnimatedMsgBox.xlsm
I am not versed with HTML DOM coding ... In the tests I carried out with various gifs, I could successfully set the backgroundcolor only in some of them. This is in order to match the gif background color with the MsgBox theme for blending.
Unless the gif is a transparent gif, much of the image quality may be affected if the gif has a background color that cannot be set.
1- API code in a Standard Module:
VBA Code:
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 RGB
R As Long
G As Long
B As Long
End Type
#If VBA7 Then
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 AtlAxWinInit Lib "Atl.dll" () As Long
Private Declare PtrSafe Function AtlAxGetControl Lib "atl" (ByVal hwnd As LongPtr, Unk As stdole.IUnknown) 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 GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
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 DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ColorHLSToRGB Lib "shlwapi.dll" (ByVal wHue As Integer, ByVal wLuminance As Integer, ByVal wSaturation As Integer) As Long
Private Declare PtrSafe Function ColorRGBToHLS Lib "shlwapi" (ByVal clrRGB As Long, ByRef wHue As Integer, ByRef wLuminance As Integer, ByRef wSaturation As Integer) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private hHook As LongPtr
#Else
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 AtlAxWinInit Lib "Atl.dll" () As Long
Private Declare Function AtlAxGetControl Lib "atl" (ByVal hwnd As Long, Unk As stdole.IUnknown) 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 GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem 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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function ColorHLSToRGB Lib "shlwapi.dll" (ByVal wHue As Integer, ByVal wLuminance As Integer, ByVal wSaturation As Integer) As Long
Private Declare Function ColorRGBToHLS Lib "shlwapi" (ByVal clrRGB As Long, ByRef wHue As Integer, ByRef wLuminance As Integer, ByRef wSaturation As Integer) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private hHook As Long
#End If
Private sURL As String
Public Function AnimatedMsgBox( _
ByVal PROMPT As String, _
Optional ByVal BUTTONS As VbMsgBoxStyle, _
Optional ByVal TITLE As String, _
Optional GIF_URL As String _
) As VbMsgBoxResult
Const WH_CBT = 5
If hHook = 0 Then
hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, GetModuleHandle(StrPtr(vbNullString)), GetCurrentThreadId)
sURL = GIF_URL
BUTTONS = BUTTONS And Not (vbInformation Or vbExclamation Or vbCritical)
AnimatedMsgBox = MsgBox(PROMPT, BUTTONS + vbInformation, TITLE)
End If
End Function
#If Win64 Then
Private Function HookProc( _
ByVal lCode As Long, _
ByVal wParam As LongLong, _
ByVal lParam As LongLong _
) As LongLong
Dim hIcon As LongLong, hWebCtrl As LongLong
#Else
Private Function HookProc( _
ByVal lCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
Dim hIcon As Long, hWebCtrl As Long
#End If
Const HC_ACTION = 0
Const HCBT_ACTIVATE = 5
Const HCBT_DESTROYWND = 4
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WS_EX_LAYERED = &H80000
Const LWA_COLORKEY = &H1
Const COLOR_WINDOW = 5
Dim tWinRect As RECT, tPt As POINTAPI
Dim Unk As IUnknown, oWbrowser As Object
Dim sClassName As String * 256, lRet As Long
Dim lWindColor As Long
On Error Resume Next
If lCode < HC_ACTION Then
HookProc = CallNextHookEx(hHook, lCode, wParam, lParam)
Exit Function
End If
If lCode = HCBT_ACTIVATE And hWebCtrl = 0 Then
lRet = GetClassName(wParam, sClassName, 256)
If Left$(sClassName, lRet) = "#32770" Then
hIcon = GetDlgItem(wParam, &H14)
Call GetWindowRect(hIcon, tWinRect)
tPt.x = tWinRect.Left: tPt.y = tWinRect.Top
Call ShowWindow(hIcon, 0)
Call ScreenToClient(wParam, tPt)
Call AtlAxWinInit
hWebCtrl = CreateWindowEx(WS_EX_LAYERED, "AtlAxWin", "about:blank", WS_VISIBLE + WS_CHILD, tPt.x, tPt.y, 32, 32, wParam, 0, 0, ByVal 0)
Call TranslateColor(GetSysColor(COLOR_WINDOW), 0, lWindColor)
Call SetLayeredWindowAttributes(hWebCtrl, vbWhite, 0, LWA_COLORKEY)
If hWebCtrl Then
Call AtlAxGetControl(hWebCtrl, Unk)
Set oWbrowser = Unk
With oWbrowser
Do: DoEvents: Loop While .ReadyState <> 4 Or .Busy
.Silent = True
.Document.body.innerHTML = "<img style=""position:absolute;top:0px;left:0px;width:" & 32 & _
"px;height:" & Fix(.Height) & "px"" src=""" & sURL & "?" & """/>"
.Document.body.Style.backgroundColor = GetHLS(lWindColor)
End With
End If
End If
End If
If lCode = HCBT_DESTROYWND Then
lRet = GetClassName(wParam, sClassName, 256)
If Left$(sClassName, lRet) = "#32770" Then
Call DestroyWindow(hWebCtrl)
hWebCtrl = 0
Call UnhookWindowsHookEx(hHook): hHook = 0
End If
End If
Call CallNextHookEx(hHook, lCode, wParam, lParam)
End Function
Private Function GetHLS(ByVal col As Long) As String
Dim sHLS As String, tARGB As RGB, tWinRect As RECT
Dim R As Byte, G As Byte, B As Byte
Dim iHu As Integer, iLu As Integer, iSa As Integer
Call ColorRGBToHLS(col, iHu, iLu, iSa)
tARGB = ColorToRGB(ColorHLSToRGB(iHu, iLu, iSa))
sHLS = "#" & Right("0" & Hex(tARGB.R), 2) & Right("0" & Hex(tARGB.G), 2) & Right("0" & Hex(tARGB.B), 2)
GetHLS = sHLS
End Function
Private Function ColorToRGB(ByVal col As Long) As RGB
ColorToRGB.R = &HFF& And col
ColorToRGB.G = (&HFF00& And col) \ 256
ColorToRGB.B = (&HFF0000 And col) \ 65536
End Function2- Test (as per the workbook demo)
VBA Code:
Option Explicit
Sub Test()
AnimatedMsgBox "Hello!", vbInformation, "Animated Gif Demo.", "https://media.giphy.com/media/3o6fJg5J8ZkVxxXERO/giphy.gif"
AnimatedMsgBox "Hypnosis may help you.", , "Animated Gif Demo.", "https://media.giphy.com/media/WZrOaNjFPKT5e/giphy.gif"
AnimatedMsgBox "Never mind.", vbAbortRetryIgnore + vbInformation, "Animated Gif Demo.", "https://media.giphy.com/media/LCf1GPRCsDMagg2kMq/giphy.gif"
AnimatedMsgBox "Use your imagination.", , "Animated Gif Demo.", "https://media.giphy.com/media/3o7TKFxkCyNzy4WiKA/giphy.gif"
AnimatedMsgBox "Use your imagination.", , "Animated Gif Demo.", "https://media.giphy.com/media/5xaOcLO449BOl4POJVu/giphy.gif"
AnimatedMsgBox "Use your imagination.", , "Animated Gif Demo.", "https://media.giphy.com/media/BfWLUK9MyFVRK/giphy.gif"
AnimatedMsgBox "Use your imagination.", , "Animated Gif Demo.", "https://media.giphy.com/media/3o6gbeVN2ZPbG2COKA/giphy.gif"
AnimatedMsgBox "Use your imagination.", , "Animated Gif Demo.", "https://media.giphy.com/media/rDb9zTgdfiPwQ/giphy.gif"
AnimatedMsgBox "Use your imagination.", , "Animated Gif Demo.", "https://media.giphy.com/media/NU4il2utBo5Lq/giphy.gif"
AnimatedMsgBox "Use your imagination.", , "Animated Gif Demo.", "https://media.giphy.com/media/9V73lQx5Sa7r14IDqT/giphy.gif"
AnimatedMsgBox "Ok. That's enough." & vbNewLine & "Point made.", , "Animated Gif Demo.", "https://media.giphy.com/media/KlokXJQBqt25G/giphy.gif"
AnimatedMsgBox "Bye!", vbExclamation, "Animated Gif Demo.", "https://media.giphy.com/media/hYD129K5IHWVMJgRvG/giphy.gif"
End SubGifs can be added from disk files or from urls.
). The 'solution' I arrived at for the VB6 PictureBox knockoff cPictureBox class module is a simple double buffering method with drawing to MemDc/MemBMP and then BitBlting to the container DC when the controls Refresh method is executed. But that's not what I tried for this challenge.
