Results 1 to 1 of 1

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

  1. #1

    Thread Starter
    Join Date
    Jul 2010

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

    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.

    -Windows XP or higher
    -oleexp v4.0 or higher
    -oleexp addon mIID.bas added (included in oleexp download)

    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 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 oleexp.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
                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
                    Debug.Print sFile & "::GetOverlayIconIndex no child pidl"
                End If
            End If
            Debug.Print "GetOverlayIconIndex::no IShellFolder"
        End If
        Call CoTaskMemFree(pcid)
        Call CoTaskMemFree(iDL)
        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)
      If Err Or (isf Is Nothing) Then
        Set GetIShellFolder = isfDesktop
        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:
    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)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Click Here to Expand Forum to Full Width