[VB6, Vista+] Direct access to the system-wide image thumbnail cache
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.
Last edited by fafalone; Nov 29th, 2016 at 07:30 PM.
Re: [VB6, Vista+] Direct access to the system-wide image thumbnail cache
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
Re: [VB6, Vista+] Direct access to the system-wide image thumbnail cache
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.