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
Last edited by fafalone; Nov 24th, 2016 at 03:52 PM.
Reason: Attached project updated to reference oleexp.tlb 4.0 or higher
Re: [VB6, Vista+] Advanced Thumbnail ListView: Icons, images, videos, framed small im
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
Last edited by fafalone; Nov 24th, 2016 at 03:53 PM.
Re: [VB6, Vista+] Advanced Thumbnail ListView: Icons, images, videos, framed small im
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?