Animated MsgBox (Added Gif)

[Jaafar Tribak]

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:

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 Function

2- Test (as per the workbook demo)

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 Sub

Gifs can be added from disk files or from urls.

 

[Dan_W]

Amazing sir, you're the best...
But what I mean is not the image on the userform but the animated image on the MsgBox, what can be set for the size while still displaying the message text because in the MsgBox that you make the animated image display in my opinion small I want to enlarge the size of the animation display. Can you tell me which part of your code to enlarge the display of the animated image, please...
Thanks...

Hi Andrie - I had wondered the same thing, and you can will see my exchange with Jaafar asking this question earlier in this thread. I tried adjusting the code to display a larger image, but as Jaafar points out, it starts to obscure the text at a certain point - from memory, that 'point' is at the 48 x 48 pixels size (or, in a pinch, maybe 64 pixels, but it would depend on the GIF).

I would echo Jaafar's suggestion - it would make more sense to use a Userform, as there isn't an obvious difference between 32px v 48px.

 

[Dan_W]

So I was doing something else entirely, and I had a sudden idea. If you adjusted the msgbox style such that the text was on the righthand side, you'd potentially have more scope for the image to make it render at a larger size... and voila:




The GIFs are at 128x128 pixels here. Of course, there is the small matter of the text, but....