[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)