[VB6, Vista+] Advanced Thumbnail ListView: Icons, images, videos, framed small images

http://i.imgur.com/nAmgaBR.jpg

I was motivated by dilettante's post to finally wrap up some of the advanced techniques I use for a top-tier thumbnail preview ListView. This combines many methods that I and others have developed for generating thumbnails, and combines them to get the best results possible and having fallback options. Not for the faint of heart.

Some of the key features:
-For non-image files, either the full-sized Vista+ style icons are used, or if unavailable the smaller icon appears in a box.
-The same is done for small image files. Instead of scaling up, which looks horrible, GDI+ is used to center and frame small images.
-Supports any image/video type Explorer supports
-Shows custom folder icons at full resolution
-Thumbnails for video files can either be turned on or off (video thumbnail method by dilettante)
-Large range of thumbnail sizes are supported; they can be set to any size you want, not just the common sizes. I'm not sure what the upper limit is but I wouldn't expect good results above 256.
-I've simplified things a little bit by doing this all with a Common Controls ocx ListView, rather than the manually created one normally used.
-Before thumbnail mode is activated, normal icon mode is shown.
-While in normal icon mode, I've incorporated my demo showing how to access and display all file overlays, instead of just the link and share ones. DropBox users rejoice!
-No external dependencies when compiled besides the Windows Common Controls, and only oleexp in the IDE.
-Includes the latest versions of my portable ListView/Header and ImageList definitions modules, current for comctl32.dll 6.1
-Gathers file information through shell interfaces, some never demonstrated in VB before now like IParentAndItem and IShellIcon.
-Detailed debug output; includes my cLog debug logging class to provide the option, by uncommenting a few lines, to log all debug output to a text file so the compiled EXE can have the output too.

Requirements
-Windows Vista or higher
-Common controls 6.0 manifest. The demo project has an internal manifest resource file for when it's compiled, but to run in the IDE your IDE must be manifested as well.
-oleexp.tlb v4.0 or higher. Revision 4 of this project was updated to reference oleexp.tlb 4.0 or higher
-oleexp's mIID.bas addon (included in oleexp download, must be added to this project).

Rev. 2 - The original post was missing some extraneous functions that prevented compiling and contained an error in handling folder thumbnails that caused a crash in the compiled EXE even though they loaded fine in the IDE. Both issues have been corrected, sorry for that.

Rev. 3 - Forgot one more thing I wanted to do; demo has been updated to show how to copy overlays (shortcut arrow, shares, etc) from the system imagelist and into the thumbnail image as an overlay so that it's drawn on the thumbnails too.

Rev. 4 - Updated to reference oleexp.tlb version 4.0 or higher

---

twinBASIC 64bit compatible version at https://github.com/fafalone/MiscDemos

Here's some selected portions of the code to give a general idea. Note that these are excerpts from the sample project and cannot run as-is.

Gathering Info

Code:

---

Private Sub LoadFolder(sPath As String)
Dim i As Long, j As Long, k As Long
Dim ctOvr As Long
Dim psi As IShellItem
Dim psiChild As IShellItem
Dim pEnum As IEnumShellItems
Dim pidl As Long
Dim uAttr As SFGAO_Flags
Dim pc As Long
Dim sFile As Long
Dim lpFile As Long
Dim pidlPar As Long, pidlRel As Long, pidlChild As Long
Dim psf As IShellFolder
Dim uPI As IParentAndItem
Dim pShIcon As IShellIcon, pShIconOvr As IShellIconOverlay
Dim lpIcon As Long
Dim pcid As Long
Dim pUnk As oleexp.IUnknown
Dim li As comctllib.ListItem
Dim lvi As LVITEM
  On Error GoTo e0
If ListView1.ListItems.Count > 0 Then
    ListView1.ListItems.Clear
    ListView_DeleteAllItems hLVS
    ResetLVIml
    Call Subclass2(hLVS, AddressOf LVSWndProc, hLVS)
End If
pidl = ILCreateFromPathW(StrPtr(sPath))
If pidl Then
    Call SHCreateItemFromIDList(pidl, IID_IShellItem, psi)
    If (psi Is Nothing) = False Then
        psi.BindToHandler 0&, BHID_EnumItems, IID_IEnumShellItems, pEnum
        ReDim glbRes(0)
        Do While (pEnum.Next(1&, psiChild, pc) = NOERROR)
            psiChild.GetAttributes SFGAO_FOLDER Or SFGAO_FILESYSTEM Or SFGAO_BROWSABLE Or SFGAO_COMPRESSED, uAttr
            ReDim Preserve glbRes(k)
            With glbRes(k)
                If (uAttr And SFGAO_FOLDER) = SFGAO_FOLDER Then
                    .bDirectory = True
                End If
                .uAttrib = uAttr
                psiChild.GetDisplayName SIGDN_FILESYSPATH, lpFile
                .sFullPath = LPWSTRtoStr(lpFile)
                lpFile = 0
                psiChild.GetDisplayName SIGDN_PARENTRELATIVEPARSING, lpFile
                .sName = LPWSTRtoStr(lpFile)
                Set uPI = psiChild
                uPI.GetParentAndItem pidlPar, psf, pidlRel
                Set pShIcon = psf
                pShIcon.GetIconOf pidlRel, GIL_FORSHELL, lpIcon
                .lIcon = lpIcon
                Set pUnk = psf
                pUnk.QueryInterface IID_IShellIconOverlay, pShIconOvr
                lpIcon = 0
                On Error Resume Next 'CRITICAL: files with no overlay return -1 AND raise a runtime error
                pShIconOvr.GetOverlayIndex pidlRel, VarPtr(lpIcon)
                On Error GoTo e0
                If lpIcon > 0 Then .lIconOvr = lpIcon
               
                'for this demo we don't need to populate any other fields.
            End With
            'Add the item
            Set li = ListView1.ListItems.Add(, , glbRes(k).sName)
            lvi.iItem = li.Index - 1
            lvi.Mask = LVIF_IMAGE
            lvi.iImage = glbRes(k).lIcon
            If glbRes(k).lIconOvr Then         
                lvi.Mask = lvi.Mask Or LVIF_STATE
                lvi.StateMask = LVIS_OVERLAYMASK
                lvi.State = INDEXTOOVERLAYMASK(glbRes(k).lIconOvr)
            End If
            ListView_SetItem hLVS, lvi
           
            k = k + 1
           
        Loop
    Else
        DebugAppend "Failed to get psi"
    End If
Else
    DebugAppend "Failed to resolve path."
End If

  On Error GoTo 0
  Exit Sub

e0:

    DebugAppend "Form1.FillFileRecords.Error->" & Err.Description & " (" & Err.Number & ")"

End Sub

---

Main thumbnail generation. Runs a file through several ways of getting a thumbnail for it, finally falling back to just the icon if no thumb is available.

Code:

---

Public Function AddThumbView2(himl_Add As Long, cxAdd As Long, cyAdd As Long, pidlFQ As Long, pidlRel As Long, sFullPath As String, bIsFolder As Boolean) As Long
'adds the thumbnail for the current file into the thumbnail imagelist
'If Win7 or greater, IShellItemImageFactory is used
'Earlier versions fall back to IExtractImage or the system image list
Dim lIdx As Long
Dim j As Long
Dim pidlPar As Long
Dim isfParent As IShellFolder
Dim bUsedISIIF As Boolean
Dim bImgFacFail As Boolean 'on thumbnail failure, set to indicate ISIIF ICONONLY should be tried

If bIsFolder Then
    lIdx = AddToHIMLNoDLL(himl_Add, pidlFQ, cxAdd, cyAdd, SIIGBF_ICONONLY)
    If lIdx = -1 Then GoTo fb2
    AddThumbView2 = lIdx
    Exit Function
End If

'If (IsWinVistaPlus = True) Then 'Major refactoring would be required to continue to support this option
If True Then
    If bExtThumbs Then 'attempt to get extended thumbnail stream
        Dim hThumbVid As Long
        If FilePtypeL(sFullPath, 0) = PERCEIVED_TYPE_VIDEO Then
            'DebugAppend "vidthumb->Attempting to get video thumbnail for " & sFullPath
            hThumbVid = AddThumbviewVideoISI(pidlFQ, cxAdd, cyAdd)
        End If
        If hThumbVid Then
            'DebugAppend "vidthumb->valid hthumb", 3
            lIdx = ImageList_Add(himl_Add, hThumbVid, 0)
            Call DeleteObject(hThumbVid)
            If (lIdx > 0) And (lIdx < 999999) Then
                'DebugAppend "vidthumb->valid lIdx return, exiting", 3
                AddThumbView2 = lIdx
                Exit Function
            End If
        Else
            'DebugAppend "vidthumb->failed to get hthumb for " & sFullPath, 2
        End If
    End If
    'DebugAppend "isifthumb->Sending DLL pidl for " & GetPathFromPIDL(pidlFQ) & "@" & CStr(himl_Add) & "," & cxAdd & "," & cyAdd
    If FileSupportsThumbView(sFullPath) Then
        lIdx = AddToHIMLNoDLL(himl_Add, pidlFQ, cxAdd, cyAdd, SIIGBF_THUMBNAILONLY Or SIIGBF_RESIZETOFIT)
            DebugAppend "isifthumb->DLL Thumb from SupportedType return::" & lIdx & "lFlags=" & j, 3
    Else
        lIdx = AddToHIMLNoDLL(himl_Add, pidlFQ, cxAdd, cyAdd, SIIGBF_ICONONLY)
        DebugAppend "isifthumb->DLL Thumb from Non-Image return::" & lIdx & "lFlags=" & j, 3
        bImgFacFail = True
    End If
    If (lIdx < 0) Or (lIdx > 999999) Then
        'DebugAppend "AddThumbView2::vidthumb/isifthumb failed, sending to gdip/iei"
        GoTo useiei
    End If
    'DebugAppend "VidThumb or DLL appears to have succeeded: thumb return::" & lIdx
    If lIdx < 0 Then
        'DebugAppend "AddTohIML failed completely, sending to defthumb"
        GoTo defthumb
    End If
    AddThumbView2 = lIdx
Else
useiei:
    Dim uThumbSize As oleexp.SIZE
    uThumbSize.CX = cxAdd
    uThumbSize.CY = cyAdd
    Dim iei As IExtractImage
    Dim sRet As String
    Dim uThumbFlags As IEIFlags
    Dim hThumb As Long, lRtn As Long
    If FileSupportsThumbView(sFullPath) Then
        'DebugAppend "AddThumbView2::Trying GDIP"
        hThumb = hBitmapFromFile(sFullPath, cxAdd, cyAdd, &HFF000000, True)
        lIdx = ImageList_Add(himl_Add, hThumb, 0)
        Call DeleteObject(hThumb)
        If lIdx > -1 Then
            DebugAppend "gdipthumb->Got valid thumb, exiting"
            AddThumbView2 = lIdx
            Exit Function
        Else
            DebugAppend "AddThumbView2::GDIP failed, will try IEI", 2

        End If 'lIdx > -1
        'DebugAppend "Attempting to get IEI thumbnail for " & GetPathFromPIDL(pidlFQ), 2
        Dim isi As IShellItem
        Call SHCreateItemFromIDList(pidlFQ, IID_IShellItem, isi)
        isi.BindToHandler ByVal 0&, BHID_ThumbnailHandler, IID_IExtractImage, iei

        If (iei Is Nothing) = False Then
            uThumbFlags = IEIFLAG_ASPECT Or IEIFLAG_SCREEN
            sRet = String$(MAX_PATH, 0)
            iei.GetLocation StrPtr(sRet), MAX_PATH, 0&, uThumbSize, 32, uThumbFlags
            hThumb = iei.Extract()
            DebugAppend "ieithumb->iei.Extract=" & hThumb, 3 'lRtn
           
            If hThumb Then
                'we now have an hBitmap that we can add to a standard api imagelist
               
                lIdx = AddToImageListEx(himl_Add, hThumb, cxAdd, cyAdd)
                Call DeleteObject(hThumb)
                If lIdx > -1 Then
                    'DebugAppend "ieithumb->Got valid thumb add, exiting", 2
                    AddThumbView2 = lIdx
                    Exit Function
                Else
                    'DebugAppend "ieithumb->Failed to add hThumb to hIML_Add, ret=" & lIdx
                    'DebugAppend "Imagewidth=" & GetImageWH(hThumb, 1) & ",h=" & GetImageWH(hThumb, 2)
                    GoTo defthumb
                End If
            Else
                'DebugAppend "Failed to get hThumb from IEI, falling back to defthumb", 2
                GoTo defthumb
            End If 'hThumb
        Else
            'DebugAppend "Could not create iei, falling back to defthumb", 2
            GoTo defthumb
        End If 'iei is nothing
    Else
defthumb:
        'can't get a thumbnail of this file
        'so we'll need to get it's associated icon from the system image list,
        'and then copy it to our image list
        Dim hIcon As Long
        DebugAppend "defthumb fallback", 2

        If FileSupportsThumbView(sFullPath) Then
            If bImgFacFail = False Then
                'the file supports thumbnail view but all attempts to generate it
                'have failed. first attempt to use ISIIF if it didn't already fail
                        lIdx = AddToHIMLNoDLL(himl_Add, pidlFQ, cxAdd, cyAdd, SIIGBF_ICONONLY)

                        If (lIdx < 0) Or (lIdx > 999999) Then
                            DebugAppend "Fallback to DLL/ICONONLY failed, sending to GetAssocIco"
                            GoTo fb2
                        Else
                            DebugAppend "Fallback to DLL/ICONONLY succeeded"
                            AddThumbView2 = lIdx
                            Exit Function
                        End If
            End If
        End If
fb2:

'        If lRtn < 0 Then
        hIcon = GetFileIconHandlePIDL(pidlFQ)
        If hIcon = 0 Then

            DebugAppend "Failed to get associated icon. Alternate method returned hIcon=" & hIcon

        End If
       
        If hIcon = 0 Then
            DebugAppend "AddThumbView2::Final fallbacks to SHGetFileInfo/SHGetImageList system icons have failed. Something weird is going on..."
        Else
            lIdx = ImageList_AddIcon(himl_Add, hIcon)
            Call DestroyIcon(hIcon)
            DebugAppend "lIdx on version fallback,==" & lIdx, 2
            AddThumbView2 = lIdx
            Exit Function
        End If
    End If
End If
'DebugAppend "AddThumbView2 last exit point,rtn=" & AddThumbView2
Call CoTaskMemFree(pidlPar)
Set isfParent = Nothing

End Function
Public Function AddToHIMLNoDLL(himl As Long, pidlFQ As Long, CX As Long, CY As Long, lFlags As SIIGBF) As Long
Dim psi As IShellItem
Dim pUnk As oleexp.IUnknown
Dim isiif As IShellItemImageFactory
Dim hr As Long

Dim hBmp As Long
hr = SHCreateItemFromIDList(pidlFQ, IID_IShellItemImageFactory, isiif)
'DebugAppend "mListviewDefs.AddToHIMLNoDLL.hr1=" & hr
hr = isiif.GetImage(CX, CY, lFlags, hBmp)
'DebugAppend "mListviewDefs.AddToHIMLNoDLL.hr2=" & hr
If hr = S_OK Then
'    DebugAppend "isiif success!"
    AddToHIMLNoDLL = ImageList_Add(himl, hBmp, 0)
    DeleteObject hBmp
Else
    AddToHIMLNoDLL = -1
'    DebugAppend "mListviewDefs.AddToHIMLNoDLL.getimage failed"
End If
Set isiif = Nothing


End Function
Public Function AddThumbviewVideoISI(pidl As Long, CX As Long, CY As Long) As Long
Dim psi As IShellItem2
Dim vProp As Variant, vrProp As Variant
Dim pKey_ThumbStream As PROPERTYKEY
Dim gidTS As UUID
Dim sguid As String
sguid = "{F29F85E0-4FF9-1068-AB91-08002B27B3D9}"
Call CLSIDFromString(StrPtr(sguid), gidTS)
pKey_ThumbStream.pid = 27
pKey_ThumbStream.fmtid = gidTS

Call SHCreateItemFromIDList(pidl, IID_IShellItem2, psi)
If (psi Is Nothing) = False Then
    psi.GetProperty pKey_ThumbStream, vProp
    PropVariantToVariant vProp, vrProp
    If VarType(vrProp) = vbDataObject Then
        AddThumbviewVideoISI = ResizeThumbFromGDIP(hBitmapFromStream(vrProp), CX, CY)
    Else
        DebugAppend "No thumbstream found, VT=" & VarType(vrProp), 2
    End If
Else
    DebugAppend "Failed to create IShellItem2", 2
End If
End Function

---

Quote:

---

Originally Posted by fafalone

Requirements
-Windows Vista or higher
-Common controls 6.0 manifest. The demo project has an internal manifest resource file for when it's compiled, but to run in the IDE your IDE must be manifested as well.
-oleexp.tlb v4.0 or higher. Revision 4 of this project was updated to reference oleexp.tlb 4.0 or higher
-oleexp's mIID.bas addon (included in oleexp download, must be added to this project).

---

I'm not very expert, but I need to insert thumbnails into my project. My difficult probably is to configurate Manifest Creator, because running my application a definition error appears (Undefined type) in mGDIP in this sentence

Public Type BP_PAINTPARAMS
cbSize As Long
dwFlags As Long
prcExclude As RECT
pBlendFunction As BLENDFUNCTION
End Type

for RECT

I'm using Windows7

Could you tell me the exact procedure to configure Manifest Creator?

(sorry for my english)

That error would only result from not having added a reference to oleexp.tlb; nothing to do with the manifest.

Hello Fafalone! Thank you so much for the great "oleexp"
The comctl32.ocx comctlLib.ListView that you use in your project does not support Chinese characters.
Using Krool's "VBCCR18. ListView"Replace, error message at runtime"[2025-06-29 13:37:08] Form1.FillFileRecords.Error->Type mismatch (13)"

There's two instances of Dim li As comctllib.ListItem you'd need to change to Dim li As LvwListItem, the type VBCCR18 uses, for it to work with VBCCR.

Quote:

---

Originally Posted by fafalone

There's two instances of Dim li As comctllib.ListItem you'd need to change to Dim li As LvwListItem, the type VBCCR18 uses, for it to work with VBCCR.

---

Hello Fafalone!
Your mentoring solution was effective in solving my problem. Thank you very much!