Display Userform in TaskBar with custom Icon and Hide Excel (mimicking a standalone application)

[Jaafar Tribak]

Hi dear excel enthusiasts,

The following little project makes your excel userform look like a standalone application by hiding the main excel window and leaving only the userform with a personalised icon added to it that shows on the TaskBar instead of the native excel icon ?

The code makes use of the Shell32.dll ITASKLIST3 Interface at runtime via low level calls to the DispCallFunc API.- (No third-party dll required, all code is self-contained)

This Shell Interface is the only way a button of your application can be added to the windows TaskBar in Windows 7 and onwards.... All resources that i have seen accross the internet rely on setting the WS_EX_APPWINDOW style flag of the userform window but this woked only in Windows XP and backwards., not anymore.



This is the Sub signature - all arguments are self-explanatory :

Sub FormToTaskBar _
    ( _
        ByVal Form As Object, _
        Optional ByVal AddIconFromPic As StdPicture, _
        Optional ByVal AddIconFromFile As String, _
        Optional ByVal FileIconIndex As Long = 0, _
        Optional ThumbnailTooltip As String, _
        Optional ByVal HideExcel As Boolean _
    )

Workbook Sample

1- API code in a Standard Module:

Option Explicit

'Jaafar Tribak @ MrExcel.com on 07/02/2020.
'Display vba userform icon in taskbar.
'Makes use of the Shell32.dll ITASKLIST3 Interface in order to work in Windows7 and onwards.

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


Private Type PROPERTYKEY
    fmtid As GUID
    pid As Long
End Type


#If VBA7 Then

    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function ExtractIconA Lib "Shell32.dll" (ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As LongPtr) As Long
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
    Private Declare PtrSafe Function SHGetPropertyStoreForWindow Lib "Shell32.dll" (ByVal hwnd As LongPtr, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
  
#Else

    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
    Private Declare Function ExtractIconA Lib "Shell32.dll" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As Long, ByRef cGUID As Any) As Long
    Private Declare Function SHGetPropertyStoreForWindow Lib "Shell32.dll" (ByVal hwnd As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) 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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

#End If




'___________________________________________________Public Routines____________________________________________________________________


Public Sub FormToTaskBar _
    ( _
        ByVal Form As Object, _
        Optional ByVal AddIconFromPic As StdPicture, _
        Optional ByVal AddIconFromFile As String, _
        Optional ByVal FileIconIndex As Long = 0, _
        Optional ThumbnailTooltip As String, _
        Optional ByVal HideExcel As Boolean _
    )



    Const VT_LPWSTR = 31
  
    #If Win64 Then
        Const vTblOffsetFac_32_64 = 2
        Dim hform As LongLong, hApp As LongLong, hVbe As LongLong, pPstore As LongLong, pTBarList As LongLong
        Dim PV(0 To 2) As LongLong
      
        PV(0) = VT_LPWSTR: PV(1) = StrPtr("Dummy")
    #Else
        Const vTblOffsetFac_32_64 = 1
        Dim hform As Long, hApp As Long, hVbe As Long, pPstore As Long, pTBarList As Long
        Dim PV(0 To 3) As Long
      
        PV(0) = VT_LPWSTR: PV(2) = StrPtr("Dummy")
    #End If


    Const IPropertyKey_SetValue = 24 * vTblOffsetFac_32_64
    Const IPropertyKey_Commit = 28 * vTblOffsetFac_32_64
    Const ITASKLIST3_HrInit = 12 * vTblOffsetFac_32_64
    Const ITASKLIST3_AddTab = 16 * vTblOffsetFac_32_64
    Const ITASKLIST3_DeleteTab = 20 * vTblOffsetFac_32_64
    Const ITASKLIST3_ActivateTab = 24 * vTblOffsetFac_32_64
    Const ITASKLIST3_SetThumbnailTooltip = 76 * vTblOffsetFac_32_64


    Const IID_PropertyStore = "{886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99}"
    Const IID_PropertyKey = "{9F4C2855-9F79-4B39-A8D0-E1D42DE1D5F3}"
    Const CLSID_TASKLIST = "{56FDF344-FD6D-11D0-958A-006097C9A090}"
    Const IID_TASKLIST3 = "{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}"

    Const CLSCTX_INPROC_SERVER = &H1
    Const S_OK = 0
    Const CC_STDCALL = 4

    Const GWL_STYLE = (-16)
    Const WS_MINIMIZEBOX = &H20000
    Const GWL_HWNDPARENT = (-8)

    Dim tClsID As GUID, tIID As GUID, tPK As PROPERTYKEY

  
    Call WindowFromAccessibleObject(Form, hform)
    Call SetProp(Application.hwnd, "hForm", hform)
    Call SetWindowLong(hform, GWL_HWNDPARENT, 0)
    Call SetWindowLong(hform, GWL_STYLE, GetWindowLong(hform, GWL_STYLE) Or WS_MINIMIZEBOX)
    Call DrawMenuBar(hform)
  
    If Not AddIconFromPic Is Nothing Then
        Call AddIcon(Form, AddIconFromPic, , FileIconIndex)
    ElseIf Len(AddIconFromFile) Then
        Call AddIcon(Form, , AddIconFromFile, FileIconIndex)
    End If

    Call CLSIDFromString(StrPtr(IID_PropertyStore), tIID)
    If SHGetPropertyStoreForWindow(hform, tIID, pPstore) = S_OK Then
        Call CLSIDFromString(StrPtr(IID_PropertyKey), tPK)
        tPK.pid = 5 ':  PV(0) = VT_LPWSTR: PV(1) = StrPtr("Dummy")
        Call vtblCall(pPstore, IPropertyKey_SetValue, vbLong, CC_STDCALL, VarPtr(tPK), VarPtr(PV(0))) 'SetValue Method
         Call vtblCall(pPstore, IPropertyKey_Commit, vbLong, CC_STDCALL) ' Commit Method
        Call CLSIDFromString(StrPtr(CLSID_TASKLIST), tClsID)
        Call CLSIDFromString(StrPtr(IID_TASKLIST3), tIID)
        If CoCreateInstance(tClsID, 0, CLSCTX_INPROC_SERVER, tIID, pTBarList) = S_OK Then
            SetProp Application.hwnd, "pTBarList", pTBarList
            Call vtblCall(pTBarList, ITASKLIST3_HrInit, vbLong, CC_STDCALL) 'HrInit Method
            Call vtblCall(pTBarList, ITASKLIST3_DeleteTab, vbLong, CC_STDCALL, hform) 'DeleteTab Method
            Call vtblCall(pTBarList, ITASKLIST3_AddTab, vbLong, CC_STDCALL, hform) 'AddTab Method
            Call vtblCall(pTBarList, ITASKLIST3_ActivateTab, vbLong, CC_STDCALL, hform) 'ActivateTab Method
            If Len(ThumbnailTooltip) Then
                Call vtblCall(pTBarList, ITASKLIST3_SetThumbnailTooltip, vbLong, CC_STDCALL, hform, StrPtr(ThumbnailTooltip)) 'ActivateTab Method
            End If
            If HideExcel Then
                Application.Visible = False
                hApp = Application.hwnd
                Call SetProp(Application.hwnd, "hApp", hApp)
                Call vtblCall(pTBarList, ITASKLIST3_DeleteTab, vbLong, CC_STDCALL, hApp) 'DeleteTab Method
                hVbe = FindWindow("wndclass_desked_gsk", vbNullString)
                If IsWindowVisible(hVbe) Then
                    Call SetProp(Application.hwnd, "hVbe", hVbe)
                    Call ShowWindow(hVbe, 0)
                    Call vtblCall(pTBarList, ITASKLIST3_DeleteTab, vbLong, CC_STDCALL, hVbe) 'DeleteTab Method
                End If
            End If
        End If
    End If
    Call SetForegroundWindow(hform): Call BringWindowToTop(hform)
  
End Sub


Public Sub ResetTaskbar(Optional ByVal Dummy As Boolean)


    #If Win64 Then
        Const vTblOffsetFac_32_64 = 2
        Dim pTBarList As LongPtr, hform As LongPtr, hApp As LongPtr, hVbe As LongPtr
  
    #Else
        Const vTblOffsetFac_32_64 = 1
        Dim pTBarList As Long, hform As Long, hApp As Long, hVbe As Long
  
    #End If


    Const ITASKLIST3_AddTab = 16 * vTblOffsetFac_32_64
    Const ITASKLIST3_DeleteTab = 20 * vTblOffsetFac_32_64
    Const CC_STDCALL = 4
  
    Dim i As Long

    pTBarList = GetProp(Application.hwnd, "pTBarList")
    hform = GetProp(Application.hwnd, "hForm")
    hApp = GetProp(Application.hwnd, "hApp")
    hVbe = GetProp(Application.hwnd, "hVbe")

    Call vtblCall(pTBarList, ITASKLIST3_DeleteTab, vbLong, CC_STDCALL, hform) 'DeleteTab Method
    For i = 1 To 2
        Call vtblCall(pTBarList, ITASKLIST3_AddTab, vbLong, CC_STDCALL, Choose(i, hApp, hVbe))  'AddTab Method
    Next i
  
    Application.Visible = True


End Sub




'___________________________________________________Private Routines____________________________________________________________________



Private Sub AddIcon(ByVal Form As Object, Optional AddIconFromPic As StdPicture, Optional ByVal AddIconFromFile As String, Optional ByVal Index As Long = 0)
  
    #If Win64 Then
        Dim hwnd As LongPtr, hIcon As LongPtr
    #Else
        Dim hwnd As Long, hIcon As Long
    #End If
  
    Const WM_SETICON = &H80
    Const ICON_SMALL = 0
    Const ICON_BIG = 1

    Dim N As Long, S As String

    Call WindowFromAccessibleObject(Form, hwnd)
    If Not AddIconFromPic Is Nothing Then
        hIcon = Form.Image1.Picture.Handle
        Call SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
        Call SendMessage(hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
    ElseIf Len(AddIconFromFile) Then
        If Dir(AddIconFromFile, vbNormal) = vbNullString Then
            Exit Sub
        End If
        N = InStrRev(AddIconFromFile, ".")
        S = LCase(Mid(AddIconFromFile, N + 1))
        Select Case S
            Case "exe", "ico", "dll"
            Case Else
                Err.Raise 5
        End Select
        If hwnd = 0 Then
            Exit Sub
        End If
        hIcon = ExtractIconA(0, AddIconFromFile, Index)
        If hIcon <> 0 Then
            Call SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
        End If
    End If
    Call DrawMenuBar(hwnd)
    DeleteObject hIcon
  
End Sub


#If Win64 Then
    Private Function vtblCall(ByVal InterfacePointer As LongLong, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As LongLong
#Else
    Private Function vtblCall(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As Long
#End If

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
    vParamType(0), vParamPtr(0), vRtn)
    If pIndex = 0& Then
        vtblCall = vRtn
    Else
        SetLastError pIndex
    End If

End Function

2- Code Usage in the UserForm Module:

Option Explicit


Private Sub UserForm_Initialize()

    Call FormToTaskBar _
        ( _
            Form:=Me, _
            AddIconFromFile:="C:\Users\Info-Hp\Downloads\canada.ico", _
            ThumbnailTooltip:="This is a UserForm Taskbar Tooltip.", _
            HideExcel:=True _
        )


End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    Call ResetTaskbar
  
End Sub

 

[Jaafar Tribak]

This is in response to a member request :

The following code uses a similar approach in order to change the excel application icon for windows 7 and later :

Workbook demo





1- API code in a Standard Module:

Option Explicit

'Jaafar Tribak @ MrExcel.com on 18/08/2020.
'Change Excel Icon.
'Makes use of the Shell32.dll ITASKLIST3 Interface in order to work in Windows7 and onwards.

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


Private Type PROPERTYKEY
    fmtid As GUID
    pid As Long
End Type


#If VBA7 Then
 
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function ExtractIconA Lib "Shell32.dll" (ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As LongPtr) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
    Private Declare PtrSafe Function SHGetPropertyStoreForWindow Lib "Shell32.dll" (ByVal hwnd As LongPtr, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
 
#Else

    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
    Private Declare Function ExtractIconA Lib "Shell32.dll" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As Long, ByRef cGUID As Any) As Long
    Private Declare Function SHGetPropertyStoreForWindow Lib "Shell32.dll" (ByVal hwnd As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) 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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

#End If


'___________________________________________________Public Routines____________________________________________________________________


Public Sub ChangeExcelIcon _
        (Optional ByVal Reset As Boolean = False, _
        Optional ByVal IconFromPic As StdPicture, _
        Optional ByVal IconFromFile As String, _
        Optional ByVal FileIconIndex As Long = 0, _
        Optional ThumbnailTooltip As String _
    )


    Const VT_LPWSTR = 31
 
    #If Win64 Then
        Const vTblOffsetFac_32_64 = 2
        Dim hVbe As LongLong, pPstore As LongLong, pTBarList As LongLong
        Dim PV(0 To 2) As LongLong
      
        PV(0) = VT_LPWSTR: PV(1) = StrPtr("Dummy")
    #Else
        Const vTblOffsetFac_32_64 = 1
        Dim hVbe As Long, pPstore As Long, pTBarList As Long
        Dim PV(0 To 3) As Long
      
        PV(0) = VT_LPWSTR: PV(2) = StrPtr("Dummy")
    #End If


    Const IPropertyKey_SetValue = 24 * vTblOffsetFac_32_64
    Const IPropertyKey_Commit = 28 * vTblOffsetFac_32_64
    Const ITASKLIST3_HrInit = 12 * vTblOffsetFac_32_64
    Const ITASKLIST3_AddTab = 16 * vTblOffsetFac_32_64
    Const ITASKLIST3_DeleteTab = 20 * vTblOffsetFac_32_64
    Const ITASKLIST3_ActivateTab = 24 * vTblOffsetFac_32_64
    Const ITASKLIST3_SetThumbnailTooltip = 76 * vTblOffsetFac_32_64


    Const IID_PropertyStore = "{886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99}"
    Const IID_PropertyKey = "{9F4C2855-9F79-4B39-A8D0-E1D42DE1D5F3}"
    Const CLSID_TASKLIST = "{56FDF344-FD6D-11D0-958A-006097C9A090}"
    Const IID_TASKLIST3 = "{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}"

    Const CLSCTX_INPROC_SERVER = &H1
    Const S_OK = 0
    Const CC_STDCALL = 4

    Const GWL_STYLE = (-16)
    Const WS_MINIMIZEBOX = &H20000
    Const GWL_HWNDPARENT = (-8)

    Dim tClsID As GUID, tIID As GUID, tPK As PROPERTYKEY
 
    If Reset Then
        Call addicon(True)
    ElseIf Not IconFromPic Is Nothing Then
        Call addicon(, IconFromPic, , FileIconIndex)
    ElseIf Len(IconFromFile) Then
        Call addicon(, , IconFromFile, FileIconIndex)
    End If
    
    Call CLSIDFromString(StrPtr(IID_PropertyStore), tIID)
    If SHGetPropertyStoreForWindow(Application.hwnd, tIID, pPstore) = S_OK Then
        Call CLSIDFromString(StrPtr(IID_PropertyKey), tPK)
        tPK.pid = 5 ':  PV(0) = VT_LPWSTR: PV(1) = StrPtr("Dummy")
        Call vtblCall(pPstore, IPropertyKey_SetValue, vbLong, CC_STDCALL, VarPtr(tPK), VarPtr(PV(0))) 'SetValue Method
         Call vtblCall(pPstore, IPropertyKey_Commit, vbLong, CC_STDCALL) ' Commit Method
        Call CLSIDFromString(StrPtr(CLSID_TASKLIST), tClsID)
        Call CLSIDFromString(StrPtr(IID_TASKLIST3), tIID)
        
        If CoCreateInstance(tClsID, 0, CLSCTX_INPROC_SERVER, tIID, pTBarList) = S_OK Then
            SetProp Application.hwnd, "pTBarList", pTBarList
            Call vtblCall(pTBarList, ITASKLIST3_HrInit, vbLong, CC_STDCALL) 'HrInit Method
            Call vtblCall(pTBarList, ITASKLIST3_DeleteTab, vbLong, CC_STDCALL, Application.hwnd) 'DeleteTab Method
            Call vtblCall(pTBarList, ITASKLIST3_AddTab, vbLong, CC_STDCALL, Application.hwnd) 'AddTab Method
            Call vtblCall(pTBarList, ITASKLIST3_ActivateTab, vbLong, CC_STDCALL, Application.hwnd) 'ActivateTab Method
            
            If Len(ThumbnailTooltip) Then
                Call vtblCall(pTBarList, ITASKLIST3_SetThumbnailTooltip, vbLong, CC_STDCALL, Application.hwnd, StrPtr(ThumbnailTooltip)) 'SetThumbnailTooltip Method
            End If
            
            If Reset Then
                     Call vtblCall(pTBarList, ITASKLIST3_SetThumbnailTooltip, vbLong, CC_STDCALL, Application.hwnd, StrPtr(vbNullString)) 'SetThumbnailTooltip Method
            End If
            
                hVbe = FindWindow("wndclass_desked_gsk", vbNullString)
                If IsWindowVisible(hVbe) Then
                    Call SetProp(Application.hwnd, "hVbe", hVbe)
                    Call ShowWindow(hVbe, 0)
                    Call vtblCall(pTBarList, ITASKLIST3_DeleteTab, vbLong, CC_STDCALL, hVbe) 'DeleteTab Method
                End If
        End If
    End If
    
    Call SetForegroundWindow(Application.hwnd): Call BringWindowToTop(Application.hwnd)
 
End Sub




'___________________________________________________Private Routines____________________________________________________________________


Private Sub addicon(Optional ByVal Reset As Boolean, Optional ByVal IconFromPic As StdPicture, Optional ByVal IconFromFile As String, Optional ByVal Index As Long = 0)
 
    #If Win64 Then
        Dim hIcon As LongPtr
    #Else
        Dim hIcon As Long
    #End If
 
    Const WM_SETICON = &H80
    Const ICON_SMALL = 0
    Const ICON_BIG = 1

    Dim N As Long, S As String
        
    If Not IconFromPic Is Nothing Then
        hIcon = IconFromPic.Handle
        Call SendMessage(Application.hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
        Call SendMessage(Application.hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
    ElseIf Len(IconFromFile) Then
        If Dir(IconFromFile, vbNormal) = vbNullString Then
            Exit Sub
        End If
        N = InStrRev(IconFromFile, ".")
        S = LCase(Mid(IconFromFile, N + 1))
        Select Case S
            Case "exe", "ico", "dll"
            Case Else
                Err.Raise 5
        End Select
        If Application.hwnd = 0 Then
            Exit Sub
        End If
        
        hIcon = ExtractIconA(0, IconFromFile, Index)
        If hIcon <> 0 Then
            Call SendMessage(Application.hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
            Call SendMessage(Application.hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
        End If
        
    ElseIf Reset Then
         hIcon = ExtractIconA(0, Application.Path & "\Excel.exe", 0)
        If hIcon <> 0 Then
            Call SendMessage(Application.hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
            Call SendMessage(Application.hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
        End If
    End If
    
    Call DrawMenuBar(Application.hwnd)
    DeleteObject hIcon
 
End Sub


#If Win64 Then
    Private Function vtblCall(ByVal InterfacePointer As LongLong, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As LongLong
#Else
    Private Function vtblCall(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As Long
#End If

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
    vParamType(0), vParamPtr(0), vRtn)
    If pIndex = 0& Then
        vtblCall = vRtn
    Else
        SetLastError pIndex
    End If

End Function

2- Code Usage :

Option Explicit

 Sub ChangeXLIcon()

    Call ChangeExcelIcon(IconFromPic:=Sheet1.Image3.Picture, _
            ThumbnailTooltip:="This is a custom Taskbar Icon Tooltip.")

End Sub


 Sub ResetXLIcon()

    Call ChangeExcelIcon(Reset:=True)
 
End Sub

 

[YasserKhalil]

@Jaafar Tribak
Thank you very much for this masterpiece.
This affects only the workbook that has the API codes. Can this be extended to include any open workbook?

 

[Jaafar Tribak]

@Jaafar Tribak
Thank you very much for this masterpiece.
This affects only the workbook that has the API codes. Can this be extended to include any open workbook?

Hi,

Before I set out to write the code, can you or anybody confirm or deny whether the Hwnd Property of the Window object exists in excel editions prior to excel 2013 ? ( ie prior to introducing the SDI interface in Excel 2013 )

In other words, does the following code compile in excel 2010, 2007 ?

MsgBox ThisWorkBook.Windows(1).hwnd
MsgBox Application.Windows.Count

Thanks.

 

[Legacy 456155]

Hi Jafaar. Is there any reason you can think of off the top of your head that this code cannot be adapted to MS Access? I would like to use it in a current project that works fine with a hidden main application window. (Only the forms show - simulating a standalone app) The only caveat is that when a form is minimized, it is minimized to the desktop and is not visible in the taskbar. I would like to use your code so that a minimized form shows in the taskbar. Before I attempt it, eventually, is it feasible?

In other words, does the following code compile in excel 2010, 2007 ?

I cannot help you there because I only don't have any of those version intalled.

 

[Jaafar Tribak]

The only caveat is that when a form is minimized, it is minimized to the desktop and is not visible in the taskbar. I would like to use your code so that a minimized form shows in the taskbar. Before I attempt it, eventually, is it feasible?

I am afraid, I am not familiar with Access.
What object are you passing in the first argument in the FormToTaskBar routine ?

 

[Legacy 456155]

What object are you passing in the first argument in the FormToTaskBar routine ?

None as of yet. I haven't tried it. I'll post back eventually on this thread with success or failure. Have a good day, Jafaar!

 

[YasserKhalil]

I am using office 365 32 Bit and no errors when opening two workbooks

Sub Test365_32Bit()
    Debug.Print ThisWorkbook.Windows(1).Hwnd    '328040
    Debug.Print Application.Windows.Count       '2
End Sub

 

[Jaafar Tribak]

@YasserKhalil

I have encapsulated the code in a class for easier use. The class (ClsXLIconMaker) has the following members which are self-explanatory:

Sub MakeIconFromPicture(ByVal Pic As StdPicture)
Sub MakeIconFromFile(ByVal IconFile As String, Optional ByVal IconIndex As Long = 0)
Property Let ThumbnailTooltip(ByVal ToolTipText As String)
Property Get ThumbnailTooltip() As String
Sub ApplyIcon
Sub RestoreDefaultIcon


As opposed to the previous code, this one should change the icon of all workbook windows that are opened within the current excel session. (See Gif image below)

Tested on Excel 2016 ... I hope it works in other excel versions.

Workbook Demo








1- Class code :

Option Explicit

'Jaafar Tribak @ MrExcel.com on 21/08/2020.
'Change Excel Icon... (all workbook windows)

    ' (ClsXLIconMaker) Class members:
    '============================
            ' Sub MakeIconFromPicture(ByVal Pic As StdPicture)
            ' Sub MakeIconFromFile(ByVal IconFile As String, Optional ByVal IconIndex As Long = 0)
            ' Property Let ThumbnailTooltip(ByVal ToolTipText As String)
            ' Property Get ThumbnailTooltip() As String
            ' Sub ApplyIcon
            ' Sub RestoreDefaultIcon

'This Class makes use of the Shell32.dll ITASKLIST3 Interface in order to work in Windows7 and onwards.

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PROPERTYKEY
    fmtid As GUID
    pid As Long
End Type


#If VBA7 Then

    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As LongPtr, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function ExtractIconA Lib "Shell32.dll" (ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As LongPtr) As Long
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As LongPtr, ByRef cGUID As Any) As Long
    Private Declare PtrSafe Function SHGetPropertyStoreForWindow Lib "Shell32.dll" (ByVal hwnd As LongPtr, ByRef riid As GUID, ByRef ppv As LongPtr) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long

#Else

    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Function CoCreateInstance Lib "ole32" (ByRef rclsid As GUID, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
    Private Declare Function ExtractIconA Lib "Shell32.dll" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal OleStringCLSID As Long, ByRef cGUID As Any) As Long
    Private Declare Function SHGetPropertyStoreForWindow Lib "Shell32.dll" (ByVal hwnd As Long, ByRef riid As GUID, ByRef ppv As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

#End If

Private hPic As StdPicture
Private sIconFile As String
Private lIconIndex As Long
Private sToolTipText As String

Private WithEvents app As Application




'___________________________________________________Class Members____________________________________________________________________

Private Sub Class_Initialize()
    Set app = Application
End Sub

Public Sub MakeIconFromPicture(ByVal Pic As StdPicture)

    If Len(sIconFile) = 0 Then
        Set hPic = Pic
    Else
        Err.Raise Number:=vbObjectError + 513, Description:="Pic and IconFile confilct."
    End If

End Sub

Public Sub MakeIconFromFile(ByVal IconFile As String, Optional ByVal IconIndex As Long = 0)

    If hPic Is Nothing Then
        sIconFile = IconFile: lIconIndex = IconIndex
    Else
        Err.Raise Number:=vbObjectError + 513, Description:="Pic and IconFile confilct."
    End If

End Sub

Public Property Get ThumbnailTooltip() As String
    ThumbnailTooltip = sToolTipText
End Property

Public Property Let ThumbnailTooltip(ByVal ToolTipText As String)
    sToolTipText = ToolTipText
End Property

Public Sub ApplyIcon()

If Not hPic Is Nothing Then
    Call ChangeExcelIcon(IconFromPic:=hPic, ThumbnailTooltip:=sToolTipText)
Else
    Call ChangeExcelIcon(IconFromFile:=sIconFile, FileIconIndex:=lIconIndex, ThumbnailTooltip:=sToolTipText)
End If

End Sub

Public Sub RestoreDefaultIcon()

    Call ChangeExcelIcon(Reset:=True)
    Set app = Nothing

End Sub




'___________________________________________________Private Routines____________________________________________________________________

Private Sub app_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
    Call Me.ApplyIcon
End Sub

Private Sub ChangeExcelIcon _
        (Optional ByVal Reset As Boolean = False, _
        Optional ByVal IconFromPic As StdPicture, _
        Optional ByVal IconFromFile As String, _
        Optional ByVal FileIconIndex As Long = 0, _
        Optional ByVal ThumbnailTooltip As String)
       
    Const VT_LPWSTR = 31

    #If Win64 Then
        Const vTblOffsetFac_32_64 = 2
        Dim hVbe As LongLong, pPstore As LongLong, pTBarList As LongLong
        Dim PV(0 To 2) As LongLong
     
        PV(0) = VT_LPWSTR: PV(1) = StrPtr("Dummy")
    #Else
        Const vTblOffsetFac_32_64 = 1
        Dim hVbe As Long, pPstore As Long, pTBarList As Long
        Dim PV(0 To 3) As Long
     
        PV(0) = VT_LPWSTR: PV(2) = StrPtr("Dummy")
    #End If

    Const IPropertyKey_SetValue = 24 * vTblOffsetFac_32_64
    Const IPropertyKey_Commit = 28 * vTblOffsetFac_32_64
    Const ITASKLIST3_HrInit = 12 * vTblOffsetFac_32_64
    Const ITASKLIST3_AddTab = 16 * vTblOffsetFac_32_64
    Const ITASKLIST3_DeleteTab = 20 * vTblOffsetFac_32_64
    Const ITASKLIST3_ActivateTab = 24 * vTblOffsetFac_32_64
    Const ITASKLIST3_SetThumbnailTooltip = 76 * vTblOffsetFac_32_64

    Const IID_PropertyStore = "{886D8EEB-8CF2-4446-8D02-CDBA1DBDCF99}"
    Const IID_PropertyKey = "{9F4C2855-9F79-4B39-A8D0-E1D42DE1D5F3}"
    Const CLSID_TASKLIST = "{56FDF344-FD6D-11D0-958A-006097C9A090}"
    Const IID_TASKLIST3 = "{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}"

    Const CLSCTX_INPROC_SERVER = &H1
    Const S_OK = 0
    Const CC_STDCALL = 4

    Dim tClsID As GUID, tIID As GUID, tPK As PROPERTYKEY

    #If VBA7 Then
            Dim hArr() As LongPtr
    #Else
            Dim hArr() As Long
    #End If

    Dim hwnd As Variant, i As Long
       
    hArr = AllWorkbookHwnds
       
    For Each hwnd In hArr
   
        If Reset Then
            Call addicon(hwnd, True)
        ElseIf Not IconFromPic Is Nothing Then
            Call addicon(hwnd, , IconFromPic, , FileIconIndex)
        ElseIf Len(IconFromFile) Then
            Call addicon(hwnd, , , IconFromFile, FileIconIndex)
        End If
       
        Call CLSIDFromString(StrPtr(IID_PropertyStore), tIID)
       
        If SHGetPropertyStoreForWindow(hwnd, tIID, pPstore) = S_OK Then
            Call CLSIDFromString(StrPtr(IID_PropertyKey), tPK)
            tPK.pid = 5 ':  PV(0) = VT_LPWSTR: PV(1) = StrPtr("Dummy")
            Call vtblCall(pPstore, IPropertyKey_SetValue, vbLong, CC_STDCALL, VarPtr(tPK), VarPtr(PV(0))) 'SetValue Method
            Call vtblCall(pPstore, IPropertyKey_Commit, vbLong, CC_STDCALL) ' Commit Method
            Call CLSIDFromString(StrPtr(CLSID_TASKLIST), tClsID)
            Call CLSIDFromString(StrPtr(IID_TASKLIST3), tIID)
           
            If CoCreateInstance(tClsID, 0, CLSCTX_INPROC_SERVER, tIID, pTBarList) = S_OK Then
                Call vtblCall(pTBarList, ITASKLIST3_HrInit, vbLong, CC_STDCALL) 'HrInit Method
                Call vtblCall(pTBarList, ITASKLIST3_DeleteTab, vbLong, CC_STDCALL, hwnd) 'DeleteTab Method
                Call vtblCall(pTBarList, ITASKLIST3_AddTab, vbLong, CC_STDCALL, hwnd) 'AddTab Method
                Call vtblCall(pTBarList, ITASKLIST3_ActivateTab, vbLong, CC_STDCALL, hwnd) 'ActivateTab Method
               
                If Len(ThumbnailTooltip) Then
                    For i = 1 To 2
                        DoEvents
                        Call vtblCall(pTBarList, ITASKLIST3_SetThumbnailTooltip, vbLong, CC_STDCALL, hwnd, StrPtr(ThumbnailTooltip))  'SetThumbnailTooltip Method
                        DoEvents
                    Next
                End If
               
                If Reset Then
                    Call vtblCall(pTBarList, ITASKLIST3_SetThumbnailTooltip, vbLong, CC_STDCALL, hwnd, StrPtr(vbNullString)) 'SetThumbnailTooltip Method
                End If
               
                hVbe = FindWindow("wndclass_desked_gsk", vbNullString)
                If IsWindowVisible(hVbe) Then
                    Call ShowWindow(hVbe, 0)
                    Call vtblCall(pTBarList, ITASKLIST3_DeleteTab, vbLong, CC_STDCALL, hVbe) 'DeleteTab Method
                End If
               
            End If
           
        End If
       
    Next hwnd

End Sub


Private Sub addicon(ByVal hwnd As Variant, Optional ByVal Reset As Boolean, Optional ByVal IconFromPic As StdPicture, Optional ByVal IconFromFile As String, Optional ByVal Index As Long = 0)

    #If VBA7 Then
        Dim hIcon As LongPtr
    #Else
        Dim hIcon As Long
    #End If

    Const WM_SETICON = &H80
    Const ICON_SMALL = 0
    Const ICON_BIG = 1

    Dim N As Long, S As String
       
    If Not IconFromPic Is Nothing Then
        hIcon = IconFromPic.Handle
        Call SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
        Call SendMessage(hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
    ElseIf Len(IconFromFile) Then
        If Dir(IconFromFile, vbNormal) = vbNullString Then
            Err.Raise Number:=vbObjectError + 513, Description:="Icon File Not found."
        End If
        N = InStrRev(IconFromFile, ".")
        S = LCase(Mid(IconFromFile, N + 1))
        Select Case S
            Case "exe", "ico", "dll"
            Case Else
                Err.Raise 5
        End Select
        If hwnd = 0 Then
            Exit Sub
        End If
       
        hIcon = ExtractIconA(0, IconFromFile, Index)
        If hIcon <> 0 Then
            Call SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
            Call SendMessage(hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
        Else
            Err.Raise Number:=vbObjectError + 513, Description:="Icon Not found."
        End If
       
    ElseIf Reset Then
         hIcon = ExtractIconA(0, Application.Path & "\Excel.exe", 0)
        If hIcon <> 0 Then
            Call SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
            Call SendMessage(hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
        End If
       
    Else
        Err.Raise Number:=vbObjectError + 513, Description:="An error has occured."
    End If
   
    Call DrawMenuBar(hwnd)

    DeleteObject hIcon

End Sub


#If VBA7 Then
    Private Function AllWorkbookHwnds() As LongPtr()
        Dim hChild As LongPtr, hArr() As LongPtr
#Else
    Private Function AllWorkbookHwnds() As Long()
        Dim hChild As Long, hArr() As Long
#End If

    Dim sBuff As String * 256, lRet As Long, i As Long
   
    If Application.Version < 15 Then
        hChild = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
        Do While hChild <> 0
            DoEvents
            lRet = GetClassName(hChild, sBuff, 256)
            If Left(sBuff, lRet) = "EXCEL7" Then
                ReDim Preserve hArr(i): hArr(i) = hChild: i = i + 1
            End If
            hChild = GetNextWindow(hChild, 5)
        Loop
    Else
        ReDim hArr(Application.Windows.Count)
        For i = 0 To Application.Windows.Count - 1
            hArr(i) = Application.Windows(i + 1).hwnd
        Next i
    End If
   
    AllWorkbookHwnds = hArr

End Function


#If Win64 Then
    Private Function vtblCall(ByVal InterfacePointer As LongLong, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As LongLong
#Else
    Private Function vtblCall(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As Long
#End If

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
    vParamType(0), vParamPtr(0), vRtn)
    If pIndex = 0& Then
        vtblCall = vRtn
    Else
        SetLastError pIndex
    End If

End Function

2- Code Usage in a Standard Module:

Option Explicit

Dim oIcon As ClsXLIconMaker


Sub Start()

    Set oIcon = New ClsXLIconMaker
   
    With oIcon
        .MakeIconFromPicture Pic:=Sheet1.Image1.Picture
        .ThumbnailTooltip = "This is a custom Taskbar Icon Tooltip."
        .ApplyIcon
    End With

End Sub


Sub Finish()

    oIcon.RestoreDefaultIcon

End Sub

 

[YasserKhalil]

Amazing Jafaar. Thank you very much. You are incredible.

 

[FTSC]

This undoubtedly is a great solution (from a great mind) to any custom excel application. I have an issue with the usage. I have a UI with more than two dozen UF's. Some of the UF's get hidden, loaded, unloaded when another UF opens/loads/show or some UF's are open on top of modal or modeless UF's. When using this solution and knowing that some forms are hidden while opening others, and some UF's are open on top of UF's that stay loaded, when switching between these UF's, the activate, initialize, query close, deactivate events don't always trigger creating several task bar icons thus allowing the the user to mistake the correct icon to select. For example. UF1 is opened/loaded and from a button on UF1 form, UF2 is loaded on top of UF1 (modal) thus creating the issue. Excel requires UF2 (modal) to be unloaded/hidden prior to returning to UF1. The two icons on the task bar allow the user to select UF1 which is behind UF2 and brings UF1 to the front and unable to use because UF2 is loaded modal and must be closed prior to return to UF1. Here is my question. Is it possible to have the icon be shown for only the topmost UF at all times. Maybe have a hook in the UF that qualifies the API code that this UF is part of the collection of UF's that you want the icon to be displayed? I tried placing the ResetTaskbar call in the query close, deactivate, terminate to unload itself but as I mentioned above some of these events do not trigger depending how the UF's are managed thus creating >1 taskbar icons.

Thanks in advance.