[VB6, Vista+] Direct access to the system-wide image thumbnail cache

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

While in general you want to use IShellItemImageFactory to get these thumbnails, as that will also return icons, if you're interested in more control or better performance, you can use IThumbnailCache and the Windows supplied implementation LocalThumbnailCache for direct access to the main system thumbnail cache.

There's a large number of additional options, and even more still if you're using Windows 8 or higher. You can choose whether to extract if not in the cache, only retrieve it if cached already, or extract it again to update the cached version. While not shown in the picture above, these thumbnails do properly render transparency.

Main routine (see full project for declares, module-level vars, etc):

Code:

---

Private Sub Command1_Click()
Dim fod As New FileOpenDialog
Dim kfPics As IShellItem
Dim tSpec() As COMDLG_FILTERSPEC
Dim pBitmap As ISharedBitmap
Dim hBmp As Long
Dim lFlag As WTS_CACHEFLAGS
Dim btID As WTS_THUMBNAILID
Dim tSZ As SIZE
Dim lOpt As WTS_FLAGS
On Error GoTo e0

ReDim tSpec(1)

tSpec(0).pszName = "Image Files"
tSpec(0).pszSpec = "*.gif;*.jpg;*.png;*.ico;*.bmp"
tSpec(1).pszName = "All Files"
tSpec(1).pszSpec = "*.*"

fod.SetClientGuid GUID_ThisProject
fod.SetTitle "Choose an image"
fod.SetOkButtonLabel "Show Thumbnail"
fod.SetOptions FOS_DONTADDTORECENT
fod.SetDefaultFolder kfPics
fod.SetFileTypes 2&, VarPtr(tSpec(0).pszName)
fod.Show Me.hWnd

On Error Resume Next
fod.GetResult psiFile
On Error GoTo e0

If (psiFile Is Nothing) = False Then
    If (pCache Is Nothing) Then
        Set pCache = New LocalThumbnailCache
    End If
    'Note: Many WTS options are Win8+ only. Here we're only demonstrating basic ones that are Win7+
    If Option1(0).Value = True Then lOpt = WTS_EXTRACT Or WTS_SCALETOREQUESTEDSIZE
    If Option1(1).Value = True Then lOpt = WTS_INCACHEONLY Or WTS_SCALETOREQUESTEDSIZE
    If Option1(2).Value = True Then lOpt = WTS_FORCEEXTRACTION Or WTS_SCALETOREQUESTEDSIZE
    If Check1.Value = vbChecked Then
        If (Option1(0).Value = True) Or (Option1(2).Value = True) Then lOpt = lOpt Or WTS_EXTRACTDONOTCACHE
    End If
    pCache.GetThumbnail psiFile, cxThumb, lOpt, pBitmap, lFlag, btID
    If (pBitmap Is Nothing) = False Then
        pBitmap.GetSize tSZ
        Debug.Print "Got bitmap obj, cx=" & tSZ.CX & ",flag=0x" & Hex$(lFlag)
        PrintThumbID btID
        pBitmap.GetSharedBitmap hBmp
        Debug.Print "hBITMAP=" & hBmp
        Picture1.Cls
        hBitmapToPictureBox Picture1, hBmp
        pBitmap.Detach hBmp
        DeleteObject hBmp
    Else
        Debug.Print "Failed to get bitmap obj, flag=0x" & Hex$(lFlag)
    End If
Else
    Debug.Print "No file selected."
End If

Exit Sub

e0:
    Debug.Print "GetThumb.Error->" & Err.Description & " (0x" & Hex$(Err.Number) & ")"
End Sub

---

Requirements
-Windows Vista or higher. Some options in demo project are Windows 7 and higher. The interface itself has many options only available on Windows 8 and higher, although none are used in the demo.
-oleexp.tlb version 4.0 or higher. Only needed for the IDE, doesn't need to be redistributed with your exe.

Notes
Thumbnails are looked up by providing an IShellItem representing the file. In the sample, this is super easy as that's what's returned from the FileOpenDialog. But without that, you can get that reference from any number of methods, including SHGetItemFromParsingName:

Code:

---

Public Declare Function SHCreateItemFromParsingName Lib "shell32" (ByVal pszPath As Long, pbc As Any, riid As UUID, ppv As Any) As Long

Call SHCreateItemFromParsingName(StrPtr(pathtofile), ByVal 0&, IID_IShellItem, psi)

---

Or from a pidl,

Code:

---

Public Declare Function SHCreateItemFromIDList Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any) As Long

---

Alternative Access to Thumbnail
Closely related, there's a very simple way to get the thumbnail of an image file (and only image file; this won't return a normal icon either) represented by an IShellItem:

Code:

---

Dim hbmTP As Long
Dim pTP As IThumbnailProvider
Dim psiImg As IShellItem

Call SHCreateItemFromParsingName(StrPtr("C:\folder\MyImage.jpg"), ByVal 0&, IID_IShellItem, psiImg)
psiImg.BindToHandler 0&, BHID_ThumbnailHandler, IID_IThumbnailProvider, pTP
If (pTP Is Nothing) = False Then
    pTP.GetThumbnail 128&, hbmTP, WTSAT_ARGB 'where 128 is the desired size. 16-256, maybe 512 work the best
    Debug.Print "hbm=" & hbmTP
    hBitmapToPictureBox Picture1, hbmTP
Else
    Debug.Print "no ptp"
End If

---

Where the hBitmapToPictureBox is the same as the demo project. This code snippet also makes use of mIID.bas from the oleexp download.
This method has the bonus of an option controlling transparency.

Hi Fafalone,
Thanks for the great work in this project. I am getting a no file selected message with the following code. Can you please offer some help? The image file definitely exists on disk.

Code:

---

Private Declare Function SHCreateItemFromParsingName Lib "shell32" (ByVal pszPath As Long, pbc As Any, riid As UUID, ppv As Any) As Long
Private psiFile As IShellItem
Private IID_IShellItem As UUID



Call SHCreateItemFromParsingName(StrPtr("C:\Users\n358924\Documents\2018-03-23 15.57.44 Ullswater.JPG"), ByVal 0&, IID_IShellItem, psiFile)


If (psiFile Is Nothing) = False Then
    If (pCache Is Nothing) Then
        Set pCache = New LocalThumbnailCache
    End If
    'Note: Many WTS options are Win8+ only. Here we're only demonstrating basic ones that are Win7+
    If Option1(0).Value = True Then lOpt = WTS_EXTRACT Or WTS_SCALETOREQUESTEDSIZE
    If Option1(1).Value = True Then lOpt = WTS_INCACHEONLY Or WTS_SCALETOREQUESTEDSIZE
    If Option1(2).Value = True Then lOpt = WTS_FORCEEXTRACTION Or WTS_SCALETOREQUESTEDSIZE
    If Check1.Value = vbChecked Then
        If (Option1(0).Value = True) Or (Option1(2).Value = True) Then lOpt = lOpt Or WTS_EXTRACTDONOTCACHE
    End If
    pCache.GetThumbnail psiFile, cxThumb, lOpt, pBitmap, lFlag, btID
    If (pBitmap Is Nothing) = False Then
        pBitmap.GetSize tSZ
        Debug.Print "Got bitmap obj, cx=" & tSZ.CX & ",flag=0x" & Hex$(lFlag)
        PrintThumbID btID
        pBitmap.GetSharedBitmap hBmp
        Debug.Print "hBITMAP=" & hBmp
        Picture1.Cls
        hBitmapToPictureBox Picture1, hBmp
        pBitmap.Detach hBmp
        DeleteObject hBmp
    Else
        Debug.Print "Failed to get bitmap obj, flag=0x" & Hex$(lFlag)
    End If
Else
    Debug.Print "No file selected."
    End
End If

---

IID_IShellItem is blank. If you're not using mIID (and if you are, simply remove the Dim for it), you need to fill it in; instead of the Dim IID_IShellItem.. use

Code:

---

Private Function IID_IShellItem() As UUID
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H43826D1E, CInt(&HE718), CInt(&H42EE), &HBC, &H55, &HA1, &HE2, &H61, &HC3, &H7B, &HFE)
IID_IShellItem = iid
End Function
Private Sub DEFINE_UUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
  With Name
    .Data1 = L
    .Data2 = w1
    .Data3 = w2
    .Data4(0) = B0
    .Data4(1) = b1
    .Data4(2) = b2
    .Data4(3) = B3
    .Data4(4) = b4
    .Data4(5) = b5
    .Data4(6) = b6
    .Data4(7) = b7
  End With
End Sub

---

or use one of the other methods of filling in a GUID.