[VB6] Code Snippet: Get file overlay (e.g. shortcut arrow), inc. customs like DropBox

[fafalone]

Everyone is familiar with the shortcut arrow-- this is an example of an overlay icon, a status indicator placed on top of another icon. Most existing VB file browser examples handle showing these by checking the attributes to see if it's a link or shared. But there's other icons- several more placed by Windows indicating things like offline files, security locks, permission shields, as well as custom ones- one of the most popular is DropBox. So if you want your app to display these as well, you need to look beyond file attributes to the IShellIconOverlay interface.

Requirements
-Windows XP or higher
VB6:
-oleexp v4.0 or higher
-oleexp addon mIID.bas added (included in oleexp download)
twinBASIC:
Windows Development Library for twinBASIC (References->Available packages)

Usage
The GetOverlayIconIndex returns a 1-based index number, so you should determine a valid choice by checking if >0. Assigning an invalid choice (<1 or >15) may result in the main icon not being rendered at all.
If you're using a control such as a ListView or TreeView and are not already assigning overlays, they're typically added like this:
lvi.StateMask = LVIS_OVERLAYMASK
lvi.State = INDEXTOOVERLAYMASK(overlayindex)

where lvi is an LVITEM and this is followed with LVM_INSERTITEM or LVM_SETITEM. TreeViews are nearly identical. Do not set the overlay if there is none (the valid results mentioned above... do not set the statemask/state if the index is 0 or -1).

The Code

Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As LongPtr) As LongPtr
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
Public Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long

Public Function GetOverlayIconIndex(sPath As String, sFile As String) As Long
'Returns the overlay index for a file icons (like the shortcut arrow)
Dim iDL As LongPtr
Dim psf As IShellFolder
Dim povr As IShellIconOverlay
#If TWINBASIC Then
'Assume using WinDevLib
Dim pUnk As IUnknownUnrestricted
#Else
Dim pUnk As oleexp.IUnknown
#End If
Dim pcid As LongPtr, pche As Long, lAt As Long

iDL = ILCreateFromPathW(StrPtr(sPath))
If iDL Then
    Set psf = GetIShellFolder(isfDesktop, iDL)
    psf.ParseDisplayName 0&, 0&, StrPtr(sFile), pche, pcid, 0&
    If (psf Is Nothing) = False Then
        Set pUnk = psf
        pUnk.QueryInterface IID_IShellIconOverlay, povr
        If (povr Is Nothing) Then
            Debug.Print "GetOverlayIconIndex failed to get ishelliconoverlay " & sFile
        Else
            If pcid Then
                Dim pio As Long
                On Error Resume Next 'CRITICAL: files with no overlay return -1 AND raise a runtime error
                povr.GetOverlayIndex pcid, pio 'VarPtr(pio) 
                GetOverlayIconIndex = pio
                On Error GoTo 0
            Else
                Debug.Print sFile & "::GetOverlayIconIndex no child pidl"
            End If
        End If
    Else
        Debug.Print "GetOverlayIconIndex::no IShellFolder"
    End If
    Call CoTaskMemFree(pcid)
    Call CoTaskMemFree(iDL)
Else
    Debug.Print "GetOverlayIconIndex::no pidl"
End If

End Function

'Generic support functions you may already have if working with IShellFolder
Public Function GetIShellFolder(isfParent As IShellFolder, pidlRel As LongPtr) As IShellFolder
  Dim isf As IShellFolder
  On Error GoTo out

  Call isfParent.BindToObject(pidlRel, 0, IID_IShellFolder, isf)

out:
  If Err Or (isf Is Nothing) Then
    Set GetIShellFolder = isfDesktop
  Else
    Set GetIShellFolder = isf
  End If

End Function
Public Function isfDesktop() As IShellFolder
  Static isf As IShellFolder
  If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
  Set isfDesktop = isf
End Function

Notes
-If a file doesn't have an overlay, the COM interface throws a runtime error (0x80004005 automation error unspecified). The code snippet above uses On Error Resume Next to suppress this, but if you have 'Break On All Errors' enabled, it will come up.

-The overlay index returned includes the standard shortcut and share overlays; you can eliminate code checking for them separately.

-Here's the INDEXTOOVERLAYMASK function mentioned earlier if you need it:

Public Function INDEXTOOVERLAYMASK(iOverlay As Long) As Long
  '   INDEXTOOVERLAYMASK(i)   ((i) << 8)
  INDEXTOOVERLAYMASK = iOverlay * (2 ^ 8)
End Function

UPDATE- Code updated to free child pidl as well; not freeing it causes memory leakage. Call CoTaskMemFree(pcid)

[nebeln]

This seems not to work in Win11. Error E_FAIL = &H80004005 is raised if the item got a shortcut icon associated.
Have not tried on my old Win10 machine due to electrical error.

[fafalone]

It's working on Win10 for me I'll try to check 11 tomorrow. If you're checking shortcut files, did you include the .lnk in the name?

I tested in tB with WinDevLib...

    Public Function GetOverlayIconIndex(sPath As String, sFile As String) As Long
    'Returns the overlay index for a file icons (like the shortcut arrow)
    Dim iDL As LongPtr
    Dim psf As IShellFolder
    Dim povr As IShellIconOverlay
    Dim pUnk As IUnknownUnrestricted
    Dim pcid As LongPtr, pche As Long, lAt As Long

    iDL = ILCreateFromPathW(StrPtr(sPath))
    If iDL Then
        Set psf = GetIShellFolder(isfDesktop, iDL)
        psf.ParseDisplayName 0&, 0&, StrPtr(sFile), pche, pcid, 0&
        If (psf Is Nothing) = False Then
            Set pUnk = psf
            pUnk.QueryInterface IID_IShellIconOverlay, povr
            If (povr Is Nothing) Then
                Debug.Print "GetOverlayIconIndex failed to get ishelliconoverlay " & sFile
            Else
                If pcid Then
                    Dim pio As Long
                    On Error Resume Next 'CRITICAL: files with no overlay return -1 AND raise a runtime error
                    povr.GetOverlayIndex pcid, pio
                    GetOverlayIconIndex = pio
                    On Error GoTo 0
                Else
                    Debug.Print sFile & "::GetOverlayIconIndex no child pidl"
                End If
            End If
        Else
            Debug.Print "GetOverlayIconIndex::no IShellFolder"
        End If
        Call CoTaskMemFree(pcid)
        Call CoTaskMemFree(iDL)
    Else
        Debug.Print "GetOverlayIconIndex::no pidl"
    End If

    End Function

    'Generic support functions you may already have if working with IShellFolder
    Public Function GetIShellFolder(isfParent As IShellFolder, pidlRel As LongPtr) As IShellFolder
      Dim isf As IShellFolder
      On Error GoTo out

      Call isfParent.BindToObject(pidlRel, 0, IID_IShellFolder, isf)

    out:
      If Err Or (isf Is Nothing) Then
        Set GetIShellFolder = isfDesktop
      Else
        Set GetIShellFolder = isf
      End If

    End Function
    Public Function isfDesktop() As IShellFolder
      Static isf As IShellFolder
      If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
      Set isfDesktop = isf
    End Function
    
    Private Sub Form_Load() Handles Form.Load
        Debug.Print GetOverlayIconIndex("C:\temp", "1.gif.lnk")
    End Sub

(Note WDL differs from oleexp in not using VarPtr for povr.GetOverlayIndex)

[nebeln]

Yes, I tried a .lnk file and I tried with a .lnk folder same error.
Also same error without VarPtr for .lnk file.
Yes, without .lnk extention for the shortcut the pidl creation fails.
I take a full path to a item and convert it to a IShellItem
And BHID it and gets the IShellFolder.
If it fails it binds to desktopfolder.
Or should it be immediate parent?
ShBindToParent API before binding to Desktop if failes?

[fafalone]

Sorry I'm not following -- "Yes, without .lnk extention for the shortcut the pidl creation fails." : This would be expected if you're trying to get an IShellItem/IShellFolder for a shortcut... you need to include the .lnk.

After SHCreateItemFromParsingName you can

    Dim upi As IParentAndItem, pidlPar As LongPtr, psf As IShellFolder, pidlRel As LongPtr
            Set upi = siItem
            upi.GetParentAndItem pidlPar, psf, pidlRel
    Dim pOvr As IShellIconOverlay
    Set pOvr = psf
    pOvr.GetOverlayIndex pidlRel, nIconOvr 'VarPtr(nIconOvr) with oleexp.tlb

[nebeln]

You asked me if I included .lnk in the name. Therefore I answered in such way
It works now as a standalone try with the pidlChild from IParentAndItem which interface had fell out of my mind.
But when I put it in an folder enumeration I get 0-value on .lnk files.
The error seems to be a ”pidl related” fault. I do put in the pidlEnum pidl extraxted from the pISI_Enum. Tried also with a full pidl combined from the startpidl and enumerated pidl but still 0-overlay. It should be index 2.
No exeption errors thank god

[fafalone]

Tried the code I posted in #3 with a folder shortcut and no problem, returns 2 -- but again you always have to include the .lnk extension to get an IShellItem, pidl, IShellFolder child, etc.

It sounds like you're not using the code I posted so I couldn't be sure of the issue without code to reproduce the problem.

[nebeln]

Yes, the code works clockwork for one IShellItem object and one IShellFolder object.
But the problem arise when I enumerate a folder’s items. Just a standard IShellItem enumeration.
And setting pIPAI for every new pISI_Enum.
In that case pidlChild as in the single object try does not work in enumeration because it does not return correct pidl.
The pidlChild in the GetParent event does not work in enumeration. Throws same error as in the first post i did.
It accepts the pidlEnum as explained.
So the the enumeration example only differs in the IParentAndItem is switching IShellItems and IShellFolders and the pidlEnum is used instead.

[fafalone]

You're going to have to post an example of the issue I can run.

[nebeln]

Yes, here it comes. Attached as a zip-file.
However in your one-file example as your sample, you are not responsible to sort out and isolate the .lnk-attribute.
If you not do so before calling this event in an enumeration there will be problems since there is no overlays associated in the non-link items.
That was the problem. I was to tired yesterday (swedish time) to sort that out.
In this sample I have done so.

Public Sub EnumFolder(ByVal pidl As Long)
   Dim pISI As IShellItem2
   Dim pIESI As IEnumShellItems
   Dim pIPIDL As IPersistIDList
   Dim pISI_Enum As IShellItem2
   Dim pIPAI As IParentAndItem
   Dim pISF As IShellFolder
   Dim pIUNK As oleexp.IUnknown
   Dim pISIO As IShellIconOverlay
   Dim pidlEnum As Long
   Dim pidlChild As Long
   Dim lDispName As Long
   Dim n As Long
   Dim nOverLayIcon As Long
   Dim dwAttribsIn As SFGAO_Flags
   Dim dwAttribsOut As Long
   Dim hr As Long
   
   If pidl = 0 Then Exit Sub
   
   hr = SHCreateShellItem(0, 0, pidl, pISI)
   
   If hr = S_OK Then
      hr = pISI.BindToHandler(0&, BHID_EnumItems, IID_IEnumShellItems, pIESI)
      If hr = S_OK Then
         n = 0
         Do While pIESI.Next(1, pISI_Enum, 0) = S_OK
            If Not (pISI_Enum Is Nothing) Then Set pIPIDL = pISI_Enum
            If Not (pIPIDL Is Nothing) Then pIPIDL.GetIDList pidlEnum
            Set pIPAI = pISI_Enum
            If Not (pIPAI Is Nothing) Then
               pIPAI.GetParentAndItem 0, pISF, pidlChild
               If Not (pISF Is Nothing) Then Set pISF = GetDesktopFolder
               Set pIUNK = pISF
               hr = pIUNK.QueryInterface(IID_IShellIconOverlay, pISIO)
            End If
            dwAttribsIn = SFGAO_LINK '<--- SELECT SHORTCUT
            pISI_Enum.GetAttributes dwAttribsIn, dwAttribsOut '<--- CHECK FOR SHORTCUTS
            If dwAttribsOut = SFGAO_LINK Then '<--- LINK ATTRIBUTES MUST BE SORTED OUT AND ISOLATED BEFORE CALLING pISIO::GetOverlayIndex
               If Not (pISIO Is Nothing) Then pISIO.GetOverlayIndex pidlChild, VarPtr(nOverLayIcon)
               pISI_Enum.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lDispName
               Form1.List1.AddItem Trim(GetStrAFromBStr(lDispName)) & " , OverLayIndex: " & CStr(nOverLayIcon)
            End If
            n = n + 1
            Set pISI_Enum = Nothing
            Set pISIO = Nothing
            CoTaskMemFree pidlEnum
         Loop
      End If
   End If
   
   Set pISI = Nothing
   Set pIESI = Nothing
   CoTaskMemFree pidl
   pidl = 0
End Sub

Fafalon's type library or similar need to be used.

Thanks for your support

[nebeln]

And here is a screenshoot from my ucListView project with correct overlay retrieved in LVN_GETDISPINFO event instead of direct in the enum procedure. Note I have custom drawing activated for greyscale icons with blue glowing edges