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

[Jaafar Tribak]

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 a performance hit.

Here, I am using an animated gif alternative... Animated gif files are easy to obtain and share and are ready to use.

Download Example





1- Class code: (Class name; IconClass)

Option Explicit

Private WithEvents UfEvents As MSForms.UserForm

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type Size
    cx As Long
    cy As Long
End Type

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

Private Const LF_FACESIZE = 32
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To LF_FACESIZE) As Byte
End Type

Private Type NONCLIENTMETRICS
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
    iPaddedBorderWidth As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
    #End If
    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.dll" 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 SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    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 Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDc As LongPtr, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
#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 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.dll" 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 SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag 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 Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
#End If


Public Function AddAnimatedIcon(ByVal Form As Object, ByVal IconURL As String) As Boolean
    Set UfEvents = Form
    AddAnimatedIcon = CreateIcon(Form, IconURL)
End Function

Private Sub UfEvents_Layout()
    Call SetIconPos(UfEvents)
End Sub


Private Function CreateIcon(ByVal Form As Object, ByVal url As String) As Boolean

    Const GWL_HWNDPARENT = (-8)
    Const WS_VISIBLE = &H10000000
    Const WS_POPUP = &H80000000
    Const WS_DISABLED = &H8000000
    Const WS_EX_TOOLWINDOW = &H80

    #If Win64 Then
        Dim hWebCtrl As LongLong, hParent As LongLong, hDc As LongLong
    #Else
        Dim hWebCtrl As Long, hParent As Long, hDc As Long
    #End If

    Dim oWbrowser  As Object, Unk As stdole.IUnknown
    Dim tTextSize As Size, sCaption  As String, lStyle As Long

    Call IUnknown_GetWindow(Form, VarPtr(hParent))
    hDc = GetDC(hParent)
    sCaption = Form.Caption
    Call GetTextExtentPoint32(hDc, sCaption, Len(sCaption), tTextSize)
    Call ReleaseDC(hParent, hDc)
    Form.Caption = Space(1 + tTextSize.cx / Len(sCaption)) & sCaption
    Call AtlAxWinInit
    lStyle = WS_POPUP Or WS_VISIBLE Or WS_DISABLED Or WS_EX_TOOLWINDOW
    hWebCtrl = CreateWindowEx(0, "AtlAxWin", "about:blank", lStyle, _
    0, 0, 0, 0, 0, 0, GetModuleHandle(vbNullString), ByVal 0)
    Call SetWindowLong(hWebCtrl, GWL_HWNDPARENT, hParent)
    If hWebCtrl Then
        Call SetProp(hParent, "hWebCtrl", hWebCtrl)
        Call AtlAxGetControl(hWebCtrl, Unk)
        Set oWbrowser = Unk
        With oWbrowser
            .Silent = True
            DoEvents
            .Document.Body.innerHTML = "<img style=""position:absolute;top:0px;left:0px;width:" & Fix(.Width) & _
            "px;height:" & Fix(.Height) & "px"" src=""" & url & "?" & ObjPtr(Form) & """/>"
            CreateIcon = CBool(Len(Dir(url))) And CBool(hWebCtrl)
        End With
    End If
   
End Function


Private Sub SetIconPos(ByVal Form As Object)

    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOACTIVATE = &H10
    Const SPI_GETNONCLIENTMETRICS = 41
    Const GW_CHILD = 5

    #If Win64 Then
        Dim hParent As LongLong, hwnd As LongLong
    #Else
        Dim hParent As Long, hwnd As Long
    #End If

    Dim tParentRect As RECT, tChildRect As RECT
    Dim tNCM As NONCLIENTMETRICS

    Call IUnknown_GetWindow(Form, VarPtr(hParent))
    hwnd = GetProp(hParent, "hWebCtrl")
    Call GetWindowRect(GetNextWindow(hParent, GW_CHILD), tChildRect)
    Call GetWindowRect(hParent, tParentRect)
    tNCM.cbSize = Len(tNCM)
    If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, tNCM, 0) Then
        With tParentRect
            Call SetWindowPos(hwnd, 0, tChildRect.Left + 5, tChildRect.Top - tNCM.iCaptionHeight - tNCM.iPaddedBorderWidth, _
            tNCM.iCaptionHeight, tNCM.iCaptionHeight, SWP_NOACTIVATE + SWP_SHOWWINDOW)
        End With
    End If

End Sub

2- This is how to use the above class for setting the gif pseudo-icon: on the UserForm.
UserForm Module:

Option Explicit

Private IconClassInstance As IconClass

Private Sub UserForm_Initialize()
    Set IconClassInstance = New IconClass
    IconClassInstance.AddAnimatedIcon Me, ThisWorkbook.Path & "\1.gif"
End Sub

For better looking icons, try using transparent gifs.

Tested on excel 2016 64bit , Windows 10 64Bit

 

[Jaafar Tribak]

Can anyone who has Windows 7 or earlier please test the code and let me know if the icons are well positioned over the caption bar ?

The code is, in theory, supposed to determine the caption metrics regardless of the windows version and\or applied theme but I would prefer to check that... A screen print of the icon being applied to a form and posted here would be great.

Thanks.

 

[ISY]

Hi

Excel 365 64 Bit Beta ----> OK!

 

[Jaafar Tribak]

Hi

Excel 365 64 Bit Beta ----> OK!

Thanks ISY for letting mme know.

Did the icons display their white background when you tested the code in your system?

 

[ISY]

Hi

 

[Jaafar Tribak]

Thanks ISY for taking the time to post those screens.

That looks exactly the same as mine because we both, happen to have the same Windows 10 Theme applied.

If we were to change the colors of the title bars and windows borders (in the Windows Display settings) to other than default white, we would get the ugly gif white background.

This is what I get when I change the theme color to green:

I will need to add code so I can dynamically change the animated gif background color from white to the current title bar theme color so it blends nicely.

 

[GWteB]

Excel 2013 (32bits) on Win10-x64:

 

[GWteB]

Excel 2013 (32bits) on Win7-x64 (VM):

 

[GWteB]

Excel 2003 on WinXP-32 (VM):

 

[Jaafar Tribak]

Thanks a lot for the various testing GWteB

The gif white background looks ugly in Win7 and Win10.
As for Win XP, I am not sure why the icon doesn't appear unless I find a computer with XP and try debugging.

Regards.