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

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,596
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

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Hi

Excel 365 64 Bit Windows 10


I'm sorry: :rolleyes:

UE5Z4Zp.jpg
 
Upvote 0
Hi ISY

Are you saying the code is not working i excel 365 ?

Have you added a valid path to an .ICO file in the AddIconFromFile argument ?

Regards.
 
Upvote 0
Hi

Have you added a valid path to an .ICO file in the AddIconFromFile argument ?


I changed the path with a 32x32 icon Nothing happened
 
Upvote 0
Hi ISY

Here is an update of the code .. Try again passing a valid icon file path using this new code update and see if it now works for you :


Workbook update

Updated API code in a Standard Module:
VBA Code: 
Option Explicit

'Jaafar Tribak @ MrExcel.com updated on 08/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 ExtractIconW Lib "Shell32.dll" (ByVal hInst As LongPtr, ByVal lpszExeFileName As LongPtr, ByVal nIconIndex As LongPtr) As Long
    Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageW" (ByVal hInst As Long, ByVal lpsz As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon 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 ExtractIconW Lib "Shell32.dll" (ByVal hInst As Long, ByVal lpszExeFileName As Long, ByVal nIconIndex As Long) As Long
    Private Declare Function LoadImage Lib "user32" Alias "LoadImageW" (ByVal hInst As Long, ByVal lpsz As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon 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

    Call DestroyIcon(GetProp(Application.hwnd, "hIcon"))

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
    Const LR_LOADFROMFILE = &H10

    Dim N As Long, S As String

    Call WindowFromAccessibleObject(Form, hwnd)
    
    If Not AddIconFromPic Is Nothing Then
    
        hIcon = AddIconFromPic.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 = ExtractIconW(0, StrPtr(AddIconFromFile), Index)
        If hIcon <> 0 Then
            Call SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
        Else
            hIcon = LoadImage(0, StrPtr(AddIconFromFile), 1, 0, 0, LR_LOADFROMFILE)
            If hIcon <> 0 Then
                Call SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
            End If
        End If
    End If
    
    Call SetProp(Application.hwnd, "hIcon", hIcon)
    Call DrawMenuBar(hwnd)
  
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



The Useform code stays the same.
 
Upvote 0
Hi

I changed the path with a 32x32 icon Nothing happened ?
 
Upvote 0
ISY said:
Hi

I changed the path with a 32x32 icon Nothing happened ?
Click to expand...

You really got me stumped with this .

I had tested the code on different installs ( Office 2007- 2010 "32-64 Bits" - 2016 "32-64 Bits" and Windows 7 and 10 both 32 and 64 bits.) and it worked as expected in all of them.... No idea why it doesn't work for you as the code seems correct .... Maybe it is due to excel 365.

Regards.
 
Upvote 0
Hi Jaafar. This is what I'm getting Win 10 64, 365. The top-left userform is unresponsive except for the command button. I hope that you get this working because I have been hoping to use something like this in an Access project. Thanks! :)

Capture.JPG
 
Upvote 0
@Jaafar Tribak It works flawless ?


ScreenShot063.jpg


PS: worksheet on the background is a separate instance of Excel.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
240
Dan_W
D
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
278
huiettcm
H
D
  • Solved
DispCallFunc - 64bit VBA
Replies
6
Views
378
Dan_W
D
W
  • Question
minimize and Maximize
Replies
4
Views
658
NdNoviceHlp
NdNoviceHlp
A
  • Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
503
RoryA
RoryA

Forum statistics

Threads
1,214,652
Messages
6,120,746
Members
448,989
Latest member
mariah3

Share this page

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