Requirements
-Windows XP or higher
-oleexp v3.3 or higher (03 Dec 2015 release or newer)
-oleexp addon mIID.bas added (included in oleexp download)
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
Code:
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long)
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 Long
Dim psf As IShellFolder
Dim povr As IShellIconOverlay
Dim pUnk As oleexp3.IUnknown
Dim pcid As Long, 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, 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 Long) 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-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:
Code:
Public Function INDEXTOOVERLAYMASK(iOverlay As Long) As Long
' INDEXTOOVERLAYMASK(i) ((i) << 8)
INDEXTOOVERLAYMASK = iOverlay * (2 ^ 8)
End Function