dcsimg
Results 1 to 4 of 4

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

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,259

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

    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
    Attached Files Attached Files

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,259

    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

  3. #3
    New Member
    Join Date
    Nov 2017
    Posts
    1

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

    Quote Originally Posted by fafalone View Post

    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)

  4. #4

Posting Permissions

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



Featured


Click Here to Expand Forum to Full Width