# 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:


		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 Function



*2*- *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 Sub


Gifs can be added from disk files or from urls.


----------



## Logit

Regretfully it does not function here. Running : Win 10 / 64 bit - Office 2007 / 32 bit


----------



## Jimmypop

Tested and works on my side. Will definitely use. Did experience issue where Giphy is blocked from running by company but workaround is I download the gif and save to a location in a folder on my PC.   🍻


----------



## Logit

Jimmypop​I tried to download a gif but Giphy wouldn't comply.

????


----------



## Logit

Ok .... managed to download an animated gif. Here is the code line I am using ... what am I doing wrong ?



		Code:
__


Option Explicit

Sub Test()

    AnimatedMsgBox "Hello!", vbInformation, "Animated Gif Demo.", "C:\Users\jimga\Desktop\giphy.gif"

End Sub


----------



## Tom.Jones

@Jaafar,

You're incredible!!!
Fantastic job !!! Amazing!!!

Tested on Win 10/64 Microsoft 365/32 and 365/64 Bit. Work excellent.


----------



## Jimmypop

Logit said:


> Ok .... managed to download an animated gif. Here is the code line I am using ... what am I doing wrong ?
> 
> 
> 
> Code:
> __
> 
> 
> Option Explicit
> 
> Sub Test()
> 
> AnimatedMsgBox "Hello!", vbInformation, "Animated Gif Demo.", "C:\Users\jimga\Desktop\giphy.gif"
> 
> End Sub


 Not sure... Maybe Jafaar can assist you...


----------



## Jaafar Tribak

Logit said:


> Ok .... managed to download an animated gif. Here is the code line I am using ... what am I doing wrong ?


@Logit

I could reproduce the issue in xl2007 Win7 x32bit. I suspect the culprit is the gif window beigng a child window (WS_CHILD style) of the MsgBox host.

I will revise the code and let you know... Thanks for testing and letting us know about the problem.


----------



## Logit

Thank you.


----------



## Jaafar Tribak

Logit said:


> Thank you.


@Logit

Ok- here is a new version which I hope will now work accross all platforms.

Animated_MsgBox_V2.xlsm

Please, try the workbook demo in the above link and let me know if it works for you. If it does, I will post the code here for future reference.


----------



## 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:


		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 Function



*2*- *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 Sub


Gifs can be added from disk files or from urls.


----------



## Logit

Perfect !  Thank you.


----------



## Jaafar Tribak

Logit said:


> Perfect !  Thank you.


Great ! 
Glad to hear the new code works in all platforms 👍


----------



## Jaafar Tribak

I am posting here the entire new working code, in case the link to the workbook demo gets broken in the future.

Animated_MsgBox_V2.xlsm

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
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long) As LongLong
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) 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 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 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 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 wFlags As Long) As Long
    
    Private hHook As LongPtr, hWebCtrl As LongPtr, lPrvWndProc 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 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 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 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 Declare Function SetWindowPos Lib "user32" (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 hHook As Long, hWebCtrl As Long, lPrvWndProc 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 Len(GIF_URL) Then
        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
    Else
        AnimatedMsgBox = MsgBox(PROMPT, BUTTONS, 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 hStaticIcon As LongLong
#Else
    Private Function HookProc( _
        ByVal lCode As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long _
    ) As Long
    
        Dim hStaticIcon As Long
#End If

    Const HC_ACTION = 0
    Const HCBT_ACTIVATE = 5
    Const HCBT_DESTROYWND = 4
    Const GWL_WNDPROC = (-4)
    Const WS_VISIBLE = &H10000000
    Const WS_POPUP = &H80000000
    Const WS_DISABLED = &H8000000
    Const WS_EX_LAYERED = &H80000
    Const WS_EX_NOACTIVATE = &H8000000
    Const GWL_HWNDPARENT = (-8)
    Const LWA_COLORKEY = &H1
    Const COLOR_WINDOW = 5
    
    Dim tWinRect As RECT
    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
            hStaticIcon = GetDlgItem(wParam, &H14)
            Call GetWindowRect(hStaticIcon, tWinRect)
            Call ShowWindow(hStaticIcon, 0)
            Call AtlAxWinInit
            hWebCtrl = CreateWindowEx(WS_EX_LAYERED + WS_EX_NOACTIVATE, "AtlAxWin", "about:blank", _
                WS_DISABLED + WS_VISIBLE + WS_POPUP, tWinRect.Left, tWinRect.Top, 32, 32, 0, 0, 0, ByVal 0)
            If hWebCtrl Then
                Call SetWindowLong(hWebCtrl, GWL_HWNDPARENT, wParam)
                lPrvWndProc = SetWindowLong(wParam, GWL_WNDPROC, AddressOf WinProc)
                Call TranslateColor(GetSysColor(COLOR_WINDOW), 0, lWindColor)
                Call SetLayeredWindowAttributes(hWebCtrl, vbWhite, 0, LWA_COLORKEY)
                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


#If Win64 Then
    Private Function WinProc( _
        ByVal hwnd As LongLong, _
        ByVal Msg As Long, _
        ByVal wParam As LongLong, _
        ByVal lParam As LongLong _
    ) As LongLong
    
    Dim hStaticIcon As LongLong
#Else
    Private Function WinProc( _
        ByVal hwnd As Long, _
        ByVal Msg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long _
    ) As Long
    
    Dim hStaticIcon As Long
#End If

    Const GWL_WNDPROC = (-4)
    Const WM_MOVE = &H3
    Const WM_DESTROY = &H2
    Const SWP_NOACTIVATE = &H10
    Const SWP_SHOWWINDOW = &H40

    Dim tIconRect As RECT

    Select Case Msg
        Case Is = WM_MOVE
            hStaticIcon = GetDlgItem(hwnd, &H14)
            Call GetWindowRect(hStaticIcon, tIconRect)
        With tIconRect
             Call SetWindowPos(hWebCtrl, 0, .Left, .Top, 32, 32, SWP_NOACTIVATE + SWP_SHOWWINDOW)
            End With
        Case Is = WM_DESTROY
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrvWndProc)
    End Select

    WinProc = CallWindowProc(lPrvWndProc, hwnd, Msg, wParam, ByVal 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



Regards.


----------



## Dan_W

As always, thank you this. I've been slowly working away at learning how to add icons to messageboxes, etc. and just when I worked out that one can display .ANI files instead of static .ICO files, you go and raise the bar by throwing in animated GIFs! This is great. I have a question - in researching how to display the .ICO files, I learnt that the msgbox has a static control on it, into which the ICO image is set with SendMessage:



		VBA Code:
__


hIconWnd = FindWindowEx(wParam, 0&, "Static", vbNullString)
SendMessage hIconWnd, STM_SETICON, hIcon, ByVal 0&


I note from your code that you also identify the same (?) static control, but I see it's to properly position the animated GIF. So I'm wondering:- is there any problem with slightly repositioning the animated GIF and slightly enlarging it? I've worked out that it's doable, but I suppose my question is whether or not it's even a good idea? (e.g. can it cause some other problems that I'm not experienced enough to appreciate, etc)


----------



## Jaafar Tribak

Hi Dan_W


> So I'm wondering:- is there any problem with slightly repositioning the animated GIF and slightly enlarging it? I've worked out that it's doable, but I suppose my question is whether or not it's even a good idea? (e.g. can it cause some other problems that I'm not experienced enough to appreciate, etc)


Just some slight redimensioning shouldn't be a problem I think, as long as the repositioned\enlarged icon\gif doesn't spill over the msgbox text or over other child elements in the msgbox. 

Otherwise, for larger icons\images, you would probably need to redimention the entire msgbox and its child elements which I guess would be more difficult and may be a bit of overkill (albeit a good coding exercise for learning).

Thanks.


----------



## Dan_W

Thanks, Jaafar. I hadn't considered whether or not it would spill over/encroach on any of the child elements - that's a good point.


----------



## Colo

EXCELlent work. I had fun! Thanks for sharing your work.


----------



## Jaafar Tribak

Thank you guys for the feedbacks.


----------



## Derick63

I'm a Noob here and still learning and I was looking to add a Progress animation so I downloaded a 30kb Spinner GIF with a transparent background, inserted Picture, Placed and scaled it then hid it, and finally recorded a macro to turn it on and off. I turn it on when a long macro is running and off when it's done.

Working is the name of the transparent background gif.
To turn On 


		VBA Code:
__


 ActiveSheet.Shapes.Range(Array("Working")).Visible = msoTrue

To turn Off


		VBA Code:
__


ActiveSheet.Shapes.Range(Array("Working")).Visible = msoFalse


----------



## AdamJustCoding

Thanks Jaafar for this great work! Tested on Office 365.

I've always shown GIF to my users in a userform via a webbrowser-control. Since my admin locked using ActiveX-Controls I was searching for another method to show GIF and found your fantastic tutorial. 
You are using here a MSGBOX... but is it possible to do the same with a standard Userform?

Greetings, Adam.


----------



## 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:


		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 Function



*2*- *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 Sub


Gifs can be added from disk files or from urls.


----------



## Dan_W

AdamJustCoding said:


> I've always shown GIF to my users in a userform via a webbrowser-control. Since my admin locked using ActiveX-Controls I was searching for another method to show GIF and found your fantastic tutorial.
> You are using here a MSGBOX... but is it possible to do the same with a standard Userform?


Hi Adam

I was interested in your comment about admin locking up use of ActiveX controls - do you know the reasoning behind that? Presumably this means that it's been removed from the toolbox in your VBA IDE. Does this ban extend to all ActiveX controls or just the webbrowser control because MS has stopped support for Internet Explorer? I ask (these many questions) because I've not heard this before, and I'm wondering what plans might be afoot with my company's IT team.

That, and my understanding was that MS have extended support for the WebBrowser control and the underlying rendering engine until 2028. Also, on a somewhat connected point, it turns out that MS are releasing a new webbrowser control to replace the old one early next year. But don't get too excited because apparently it is only being made available to Access VBA users... with no mention of it being released to users of the rest of the Office suite! 

Anyway.... rant over... Forgive me you've already thought about this or if you were already aware, but I wonder if this would also prevent you from creating a webbrowser control at runtime (meaning that you don't actually having to draw it with the toolbox component). For example, if you put this into a new userform, run the userform and then click on it:



		VBA Code:
__


Option Explicit
Dim WebBrowser As Object
Private Sub UserForm_Click()
    Set WebBrowser = Me.Controls.ADD("Shell.Explorer.2", "WB1")
    Me.BackColor = RGB(250, 250, 250)
    Me.Width = 440
    Me.Height = 220
    With WebBrowser
        .Left = 0
        .Top = Me.InsideHeight / 2 - 50
        .Height = 150
        .Width = Me.InsideWidth + 10
        .silent = True
        .Navigate "https://i.giphy.com/media/XgwkNbXTf7wGY/100.gif"
    End With
End Sub


Should hopefully result in:





I'd be curious to know if that works. If not, no matter, subject to anything you might hear back re: your question above, I have some other ideas.


----------



## Dan_W

Also, I don't know why I didn't think of it earlier, and it may be that you have since come across them, but I suspect these projects by Jaafar will be useful: 









						Animated GIF placed on the UserForm Title Bar (Pseudo-Icon)
					

Hi,  For a static icon, sending the WM_SETICON to the UserForm window is the standard way and it is straightforward. However, for an animated icon, we would need to use multiple images\frames and periodically alternate them in a timer procedure or in a loop. This can become quite tedious and has...




					www.mrexcel.com
				











						Dispalying Gif Preview Upon Hyperlink Mouseoever
					

Hia all,  Let's say I have a cell with the address of a gif url . I am looking for a way to display a small preview of the gif url next to the cell upon moving the mouse pointer over the cell with the url address.  I am aware of this nice trick which passes a UDF to the Hyperlink function in...




					www.mrexcel.com


----------



## AdamJustCoding

Dan_W said:


> Hi Adam
> 
> I was interested in your comment about admin locking up use of ActiveX controls - do you know the reasoning behind that? Presumably this means that it's been removed from the toolbox in your VBA IDE. Does this ban extend to all ActiveX controls or just the webbrowser control because MS has stopped support for Internet Explorer? I ask (these many questions) because I've not heard this before, and I'm wondering what plans might be afoot with my company's IT team.
> 
> That, and my understanding was that MS have extended support for the WebBrowser control and the underlying rendering engine until 2028. Also, on a somewhat connected point, it turns out that MS are releasing a new webbrowser control to replace the old one early next year. But don't get too excited because apparently it is only being made available to Access VBA users... with no mention of it being released to users of the rest of the Office suite!
> 
> Anyway.... rant over... Forgive me you've already thought about this or if you were already aware, but I wonder if this would also prevent you from creating a webbrowser control at runtime (meaning that you don't actually having to draw it with the toolbox component). For example, if you put this into a new userform, run the userform and then click on it:
> 
> 
> 
> VBA Code:
> __
> 
> 
> Option Explicit
> Dim WebBrowser As Object
> Private Sub UserForm_Click()
> Set WebBrowser = Me.Controls.ADD("Shell.Explorer.2", "WB1")
> Me.BackColor = RGB(250, 250, 250)
> Me.Width = 440
> Me.Height = 220
> With WebBrowser
> .Left = 0
> .Top = Me.InsideHeight / 2 - 50
> .Height = 150
> .Width = Me.InsideWidth + 10
> .silent = True
> .Navigate "https://i.giphy.com/media/XgwkNbXTf7wGY/100.gif"
> End With
> End Sub
> 
> 
> Should hopefully result in:
> View attachment 80931
> 
> I'd be curious to know if that works. If not, no matter, subject to anything you might hear back re: your question above, I have some other ideas.



Hey Dan,

thanks for your answer...
all blocking was done for security reasons. ActiveX is evil, Add-ins are evil... oh stop... we have an important Add-in... so Add-ins are allowed again... but ActiveX-Controls not... (Options/Trust Center/ActiveX: All deactivated... and not possible for the user to change per GPO).

I tried your code example: Runtime Error (sorry, german Version): 




Same sentence you see if you try to put a wb-control in IDE at userform.

So I still have a little hope, that Jaafars code will work with userforms, too. 
So, if a MsgBox can show GIF, maybe a userform can do it without an wb-control, too ? )

Greetings, 

Adam


----------



## Dan_W

Ahh,  well it was work a shot. And thank you for replaying the internal 'ActiveX is evil' monologue.  

I don't know if you saw it yet, but my second reply to your message above includes links to two of Jaafar's animated GIF related projects where he uses that same method here as he did with the MsgBox - that is, creating the *AtlAxWin* window, and you will see that the first one is actually on the user form.


----------



## AdamJustCoding

Ooooh... While I was studying Jaafar's code , I#ve overlooked these both examples, thanks for this hint. 
I tried both. They work perfect. Know let me try to find out, how to put some GIF into the the userform below the titlebar.
I'm very excited.


----------



## Jaafar Tribak

@AdamJustCoding

It is actually easier to add the animated gifs in the client area of a userform. Attaching the gif to a frame control would be ideal since frames are windowed controls and have a hwnd.

I have wrapped the code in this *AddGif* SUB . The SUB takes 3 optional arguments for _Backcolor_, _Background Transparency_ and _Border Frame_.

GifInForm.xlsm










*1*- Place the following code in a Standard Module:


		VBA Code:
__


Option Explicit

Private Type RGB
    R As Long
    G As Long
    B As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long) As LongLong
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  #End If
    Private Declare PtrSafe Function AtlAxWinInit Lib "Atl.dll" () As Long
    Private Declare PtrSafe Function AtlAxCreateControl Lib "atl" (ByVal lpszName As LongPtr, ByVal hContainer As LongPtr, pStream As Any, ppUnkContainer As stdole.IUnknown) As Long
    Private Declare PtrSafe Function AtlAxGetControl Lib "atl" (ByVal hContainer As LongPtr, Unk As stdole.IUnknown) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) 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 hContainer As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function AtlAxWinInit Lib "Atl.dll" () As Long
    Private Declare Function AtlAxCreateControl Lib "atl" (ByVal lpszName As LongPtr, ByVal hContainer As LongPtr, pStream As Any, ppUnkContainer As stdole.IUnknown) As Long
    Private Declare Function AtlAxGetControl Lib "atl" (ByVal hContainer As LongPtr, Unk As stdole.IUnknown) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) 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 hContainer As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
#End If



Public Sub AddGif( _
    ByVal Container As Object, _
    ByVal URL As String, _
    Optional ByVal BackColor As Long = -1, _
    Optional ByVal TansparentBackground As Boolean = True, _
    Optional ByVal Border As Boolean = False _
)

    Const S_OK = 0&, WS_EX_LAYERED = &H80000, GWL_EXSTYLE = &HFFEC, LWA_COLORKEY = &H1
 
    Dim Unk As stdole.IUnknown, oWbrowser As Object
    Dim hContainer As LongPtr, hBrowserCtrl As LongPtr
 
 
    If IUnknown_GetWindow(Container, VarPtr(hContainer)) <> S_OK Then
        MsgBox "Gif Container doesn't have a hwnd.", , "Error": Exit Sub
    End If
    If CBool(AtlAxWinInit) = False Then
        MsgBox "Unable to initialize ATL's control hosting.", , "Error": Exit Sub
    End If
    If AtlAxCreateControl(StrPtr(URL), hContainer, ByVal 0&, Unk) <> S_OK Then
        MsgBox "Unable to create ActiveX control.", , "Error": Exit Sub
    End If
    Call IUnknown_GetWindow(Unk, VarPtr(hBrowserCtrl))
    If AtlAxGetControl(hBrowserCtrl, Unk) <> S_OK Then
        MsgBox "Unable to get the interface pointer to the ActiveX control.", , "Error": Exit Sub
    End If
    If TansparentBackground Then
        Call SetWindowLong(hContainer, GWL_EXSTYLE, _
            GetWindowLong(hContainer, GWL_EXSTYLE) Or WS_EX_LAYERED)
        Call SetLayeredWindowAttributes(hContainer, vbWhite, ByVal 0&, LWA_COLORKEY)
    End If
    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:" & Fix(.Width) & _
        "px;height:" & Fix(.Height) & "px"" src=""" & URL & "?" & """/>"
        If BackColor <> -1 Then
            .Document.body.bgcolor = GetHLS(BackColor)
        End If
        If Border Then
           With .Document.body.Style
               .BorderStyle = "outset"
               .BorderColor = "black"
               .borderwidth = "thin"
           End With
        End If
    End With

End Sub

Private Function GetHLS(ByVal Col As Long) As String

    Dim sHLS As String, tARGB As RGB
    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 Clr As Long) As RGB
    With ColorToRGB
        .R = &HFF& And Clr
        .G = (&HFF00& And Clr) \ 256&
        .B = (&HFF0000 And Clr) \ 65536
    End With
End Function




*2*- *Code Usage Examples* :


UserForm1 example:


		VBA Code:
__


Option Explicit

Private Sub UserForm_Initialize()
    Dim sURL As String
    sURL = "https://media.giphy.com/media/3o6fJg5J8ZkVxxXERO/giphy.gif"
    Call AddGif(Me.Frame1, sURL)
End Sub



UserForm2 example


		VBA Code:
__


Option Explicit

Private Sub UserForm_Initialize()

    Dim sURL As String
 
    sURL = "https://i.gifer.com/Pxcu.gif"
    Call AddGif(Me.Frame1, sURL)
 
    sURL = "https://i.gifer.com/CThU.gif"
    Call AddGif(Me.Frame2, sURL)
 
    sURL = "https://i.gifer.com/YdBO.gif"
    Call AddGif(Me.Frame3, sURL, vbBlue, , True)

End Sub


----------



## AdamJustCoding

OMG... Jaafar.. can you read my mind?
I tried first to understand your code of Animated GIF placed on the UserForm Title Bar (Pseudo-Icon).
After I found out, that the GIF is attached to the title-bar (and not a child-window of the userform) and always setting position in uf-layout-event, I thought about that possibility, if the webcontrol could be placed directly into the nonclientarea as child-window.
I played around and hid the uf, made the gif bigger and screen-centered. Ok, a dirty hack.

With your new code you gave me the direct shot.
This works perfectly. 

I tried to change the "web-control-host" from frame to nonclientarea... that worked, too.
I'm speechless... 

Sometimes I think, I've seen all in VBA and there comes Jaafar, grins a little, and opens up a new universe to me (subclassing and hooking-> is somewhere an easy(!) tutorial out there?)

With this example I got, what I wanted at least...

Next-level question: Is it possible, to make a window with this webcontrol just without using an userform? Just WIN32-Api calls, like Create/ShowWindow?

By the way... where can I find more "expert" vba stuff like this? All books I've found are for beginners and advanced (but here still at low level).
Which topics (like hooking) did I miss, too?

Thanks Jaafar and Dan, so much.
VBA still lives !

Greetings, 
Adam
P.S. Funny side-effect of putting GIF to nonlientarea: the frame gets a "screenshot" of background where the userform appears.


----------



## Jaafar Tribak

@AdamJustCoding



> With your new code you gave me the direct shot.
> This works perfectly.


Glad it worked for you and thanks for the feedback.



> Is it possible, to make a window with this webcontrol just without using an userform? Just WIN32-Api calls, like Create/ShowWindow?


Should be feasible but the container of the gif browser would need to be subclassed in order to handle necessary window messages such as moving the window, closing it etc ... I would be wary to use subclassing in vba in a scenario like that.



> By the way... where can I find more "expert" vba stuff like this?


The internet is what I use. I sometimes look at code written in other languages like C. I try to understand it and see if i can tranlate the code to vba. Also, I visit VBForums where there is plenty of advanced stuff to learn from and where some amazing true hardcore vb coders share their knowledge.


----------



## Dan_W

Jaafar Tribak said:


> The internet is what I use. I sometimes look at code written in other languages like C. I try to understand it and see if i can tranlate the code to vba. Also, I visit VBForums where there is plenty of advanced stuff to learn from and where some amazing true hardcore vb coders share their knowledge.


...and I learn from the source code that Jaafar posts, so I suppose we can call it 'trickle down education'. 🤣
I think what most people don't realise is just how similar (identical?) VBA is to the VB6 language, and so a lot of the VB6 source code can be used in VBA at times with little if any modification. (EDIT: I should perhaps qualify this statement slightly by saying that: (a) that's certainly the case at the less-advanced end of the spectrum and( (b) is less-so the case since the great schism of 32bit->64bit). 

As for the transparency point, I hadn't appreciated at all that the GIF window would need to be subclassed - but it makes complete sense (and would explain why my computer keeps beeping at me (annoyed) when I got to click on the GIF.  *@AdamJustCoding* - how would you need to use the GIF? Meaning, would you need to be able to move it around, etc, or ...? As I said above, I may have a back-up option, but it is possibly not appropriate depending on your needs.


----------



## AdamJustCoding

> "...where some amazing true hardcore vb coders share their knowledge."


... said the true hardcode vb coder... 

I tried yester- and today to build a window with VBA and C++-Functions. Done. Works. But: Strange things will happen, if you debug step-by-step: the window appears instead of WIN10- in old-(maybe Win95?)-Style.. debugging stops at some point, the titlebar of vba-ide flashes and: all crashes, the VBA-project disappears. No backup, no mercy. Will have to do it after weekend again, lol. Then I'll try (after backup) to attach the gif to the window.

The GIF I want to use as Splashscreen, as mini-tutorial-animation for user-help, waiting-(processing)-forms. Since the window has a title-bar, it is moveable. A splashscreen doesn't need that, I assume, but could have this feature as office-splashscreens have. The helper-gifs are static in position. So, it depends.

But at the end I learned a lot and have a new things to play with


----------



## 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:


		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 Function



*2*- *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 Sub


Gifs can be added from disk files or from urls.


----------



## Dan_W

So, this isn't perfect or pretty, but this is what I've managed to cobble together thus far:








_(For some reason, the animated GIF doesn't seem to want to display the moment I post this, so on the off-chance you can't see it in action - this hyperlinked Thumbnail should take you to the original GIF. )_





It may be the case that I'm doing something horribly wrong, resulting in memory leaks all over the place (which is not unheard of, TBH...) but this is how I kind of approached it a while back when I first started learning about Win32 APIs.

Subject to any comments from anyone, I will upload an updated workbook (prepared by Jaffar) with the above userform and revised code, I've sort of shoehorned some things into the existing module without much thought for whether structurally it makes sense to put it there.

The key points are:


*Transparency* - I piggybacked off the code already re: applying a transparency to the GIF/container, and then extending that approach to the UserForm:



		VBA Code:
__


         Call SetWindowLong(hFormHwnd, GWL_EXSTYLE, _
            GetWindowLong(hFormHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED)                         ' DW Addendum: This extends the transparency
        Call SetLayeredWindowAttributes(hFormHwnd, vbWhite, ByVal 0&, LWA_COLORKEY)       ' being set above,



*Removed the titlebar and borders. *



		VBA Code:
__


 WindowStyle = GetWindowLong(hFormHwnd, GWL_STYLE)                                   ' DW Addendum: Removes the title bar
        WindowStyle = WindowStyle And (Not WS_CAPTION)                                      '
        SetWindowLong hFormHwnd, GWL_STYLE, WindowStyle                                     '
  
        WindowStyle = GetWindowLong(hFormHwnd, GWL_EXSTYLE)                                 ' DW Addendum: Removes the border
        WindowStyle = WindowStyle And Not WS_EX_DLGMODALFRAME                               '
        SetWindowLong hFormHwnd, GWL_EXSTYLE, WindowStyle                                   '
  
        DrawMenuBar hFormHwnd                                                               ' DW Addendum



*Leveraged the CommandButton Default Property *- CommandBars have a Default property and a Cancel property, which are activated when the user presses the enter key (thereby activating the button with the Default property set to True) or escape (where the Cancel property is set to True). It appears that this will

 get around the whole 'angry beeping computer' issue.
Here is a screen capture of how it looks at design time. In the initialize event, I move the commandbuttons 'out of frame' by setting their left properties to be negative 100 or something.


*Movement* - It isn't obvious from the GIF above, but when I activate the desginated Default Button (OK), it makes the "Move Me" label visible. Once this is visible, it gives us something to give us (the user) to 'grab on to'. This is the only way I could think of to get around the aforementioned 'angry beeping computer' issue. This is what I used to do back before I knew that subclassing was even a thing.

So like I said - it's not pretty or perfect, but if you're just wanting to use it for a splash screen, do you think this would be appropriate? I would just make the point that it really depends on the GIF animation. Some of them - when applied to a transparent background - look ridiculous. I understand that this is because of the compression used to encode the GIF file, so a lot of pixels/colours are removed in the encoding process because there is an assumption of there being a solid colour background that the GIF image can rely on.
Is that what you were thiinking? Feedback/comments always appreciated.
I need to head out to lunch but will be post the workbook/code the moment I get back.


----------



## Dan_W

*Workbook example: **GifInForm_DW.xlsm*

Hopefully this works .


----------



## Jaafar Tribak

Dan_W said:


> *Workbook example: **GifInForm_DW.xlsm*
> 
> Hopefully this works .


I coudn't locate the file.


----------



## Dan_W

Jaafar Tribak said:


> I coudn't locate the file.


My apologies - this should work now: *link*.


----------



## Jaafar Tribak

Sorry Dan for the late feedback. I just got a chance to look at your workbook example. Thanks.

Since the request was for a splash screen (which is supposed to be short lived) , I think, it wouldn't be inapropriate or risky to temporarly use a windows timer or even better a Do_DoEvents_Loop during the live of the splash screen. The idea is to be able to monitor the mouse location and state while the splash screen is being displayed. If the mouse is over the splash screen set the mouse capture. Also, hopefully, one could add a small close button in one corner of the splash screen.




.


----------



## Dan_W

Thank you kindly for the feedback. 

As regards the transparency, I had hoped to be able to use the WIA COM Object to extract out the frames and to use either the stdPicture render method (middle image below) or the ImageList's draw method (right image) to animate the frames, but unfortunately, something happens to the transparency layer throughout the course the GIF, and what should be clear is now black. It's disappointing, but oh well. Worth a try.


----------



## Jaafar Tribak

Hi Dan, 

Is the gif from which you extracted the frames a tranparent gif ? and are you rendering the images on an image control ?

Regarding posts #31/#32, using transparent gifs give good results. I have tweaked your code to overcome some of the issues you mentioned in post#31.


----------

