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

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,779
Office Version
  1. 2016
Platform
  1. Windows
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 :
Code:
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

UserFormInTaskbar_32_64.gif






1- API code in a Standard Module:
VBA Code:
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:
VBA Code:
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
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Found this thread as I was searching for a slick way of allowing user forms to minimize to taskbar.
Unfortunately I'm experiencing the same issue as user ISY and dataluver. The icon portion appears to work either by referencing the image in the worksheet or a custom .ico file.
The userform however appears as static/windowless in top left corner of my main monitor/screen. In addition, an empty userform appears with no controls. A minimize button is not present but if I click the icon on the taskbar, the static, windowless form toggles between visible and hidden. (It does not have the standard minimize animation.)
If I close the form, either with the Close button on the windowless form or by clicking the red X on the empty form window, and then re-open it, I am not able to hide it by clicking on the taskbar icon. It only works first time it's launched.
If I remove HideExcel:=True from the FormToTaskbar call, only the empty userform appears with no controls inside.

Windows 10 Pro 64-bit
Excel for Office 365 MSO (16.0.11929.20760) 64-bit
 
Upvote 0
Found this thread as I was searching for a slick way of allowing user forms to minimize to taskbar.
Unfortunately I'm experiencing the same issue as user ISY and dataluver. The icon portion appears to work either by referencing the image in the worksheet or a custom .ico file.
The userform however appears as static/windowless in top left corner of my main monitor/screen. In addition, an empty userform appears with no controls. A minimize button is not present but if I click the icon on the taskbar, the static, windowless form toggles between visible and hidden. (It does not have the standard minimize animation.)
If I close the form, either with the Close button on the windowless form or by clicking the red X on the empty form window, and then re-open it, I am not able to hide it by clicking on the taskbar icon. It only works first time it's launched.
If I remove HideExcel:=True from the FormToTaskbar call, only the empty userform appears with no controls inside.

Windows 10 Pro 64-bit
Excel for Office 365 MSO (16.0.11929.20760) 64-bit

The issue appears to happen in office 365. I have no idea why and unfortunatly, I don't have office 365 to test & debug the code.
 
Upvote 0
Hi Jaffar,

I'm a long time lurker and learned a lot from codes you posted in the past, and I have to say this is really cool!

For some time I searched for a solution to display excel through a userform with its own icon in the taskbar, thought it wasn't possible

What makes this really interesting is the fact that when I run this on a separate instance of excel it splits the icons in the taskbar, which is really cool:

1591820137497.png


But as you can see I also have 365 and it doesnt show the form properly.

Bellow is what I have been using for a while in my forms, the difference is the fact that the excel icon in the taskbar groups excel files and retains the excel icon itself.

1591820574456.png


I'll check later if I can help understand or maybe adapt something, though I dont't have any hope for this cause I'm still very inexperienced in api calls.
 
Upvote 0
Hi Jaafar,

In Excel 365 64 Bit Windows 10 I get the same pictures like Iso (UserForm in 2 parts)
In TaskBar it's show that butterfly cause I don't change path for .ico
 
Upvote 0
Hi Jaafar,

I was able to get it to work here.

First in the Module I figured out this line was causing trouble:
VBA Code:
Call WindowFromAccessibleObject(Form, hform)

I switched it for:
VBA Code:
hform = FindWindow("ThunderDFrame", Form.Caption)

This alone fixed the main issue, but the icon shown was not correct. It was still showing the excel icon

So I just used this to apply the icon:
VBA Code:
Private Sub addicon2()

Dim hwnd As LongPtr
Dim lngRet As LongPtr
Dim hIcon As LongPtr

hIcon = Planilha1.Image1.Picture.Handle
hwnd = FindWindow(vbNullString, Me.Caption)
lngRet = SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
lngRet = SendMessage(hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
lngRet = DrawMenuBar(hwnd)

End Sub

Full Code bellow:
On a Standard Module:

VBA Code:
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

    hform = FindWindow("ThunderDFrame", Form.Caption) '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    
    '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

On the Userform Module:

VBA Code:
Option Explicit

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

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
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 DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long

Private Sub UserForm_Activate()

addicon2

End Sub

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

Private Sub addicon2()

Dim hwnd As LongPtr
Dim lngRet As LongPtr
Dim hIcon As LongPtr

hIcon = Planilha1.Image1.Picture.Handle   '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Change this acording to the sheet and image of the icon location
hwnd = FindWindow(vbNullString, Me.Caption)
lngRet = SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
lngRet = SendMessage(hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
lngRet = DrawMenuBar(hwnd)

End Sub

Download

I should note I only tested this on 365 64, I did not add compatibility for 32bit on the userform code part

And I also have no idea why this works
 
Upvote 0
Hi ldrag

Thank you very much for following this up, for pinpointing what might have been the culprit when tested in Office 365 and thank you for letting me know.

WindowFromAccessibleObject function for getting the form's hwnd is what I normally use instead of using FindWindow because you don't have to worry about the userform class name (which changes depending on the excel version) nor do you have to worry about another window being shown with the same caption.

I am really surprised that WindowFromAccessibleObject didn't work and I don't see why. Anyway, there is this alternative undocumented API function by the name of IUnknown_GetWindow exported with ordinal#172 by the shlwapi dll and which I am using now.

Can you, or anybody else please, download the updated code in the workbook example below, and post back with the result you get ?

Workbook example.

There was also another stupid bug in the initial code which I have now corrected.

Thank you.
 
Upvote 0
Thanks guys for confirming that now, the code update works in Office 365 (both, 32bit and 64bit)

For future reference, I am posting below the final code that works accross all versions:

Workbook Example


1- In a Standard Module:
VBA Code:
Option Explicit

'Jaafar Tribak @ MrExcel.com on 07/02/2020. (update 14/06/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 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 FormToTaskBar _
    ( _
        ByVal Form As Object, _
        Optional ByVal IconFromPic As StdPicture, _
        Optional ByVal IconFromFile 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 IUnknown_GetWindow(Form, VarPtr(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 IconFromPic Is Nothing Then
        Call addicon(Form, IconFromPic, , FileIconIndex)
    ElseIf Len(IconFromFile) Then
        Call addicon(Form, , IconFromFile, 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 IconFromPic As StdPicture, Optional ByVal IconFromFile 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 IUnknown_GetWindow(Form, VarPtr(hwnd))
       
    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
            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 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)
        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 example ( UserForm Module)
VBA Code:
Option Explicit


Private Sub UserForm_Initialize()

    Call FormToTaskBar( _
            Form:=Me, _
            IconFromPic:=Sheet1.Image1.Picture, _
            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


'==========================================================
'Alternatively, you can add an icon to the userform from an ICO file as follows:
'Change the Icon file path\name as required.
'===========================================================

'            Private Sub UserForm_Initialize()
'
'                Call FormToTaskBar( _
'                        Form:=Me, _
'                        IconFromFile:="C:\....\MyIcon.ico", _
'                        ThumbnailTooltip:="This is a UserForm Taskbar Tooltip.", _
'                        HideExcel:=True _
'                    )
'
'            End Sub
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top