Page 1 of 2 12 LastLast
Results 1 to 10 of 20

Thread: Extract Thumbnail preview from file

  1. #1
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,347
    Post Thanks / Like
    Mentioned
    39 Post(s)
    Tagged
    3 Thread(s)

    Default Extract Thumbnail preview from file

    Hi all,

    workbook example

    Extracting a thumbnail from a file (thumbnail as shown in windows file explorer) normally requires the use of a typelib but with the assistance of the handy DispCallFunc API function, one can execute a requested interface Method w/o the need of an external typelib.


    1- API code in a Standard Module:
    Code:
    Option Explicit
    
    Type Size
        cx As Long
        cy As Long
    End Type
    
    Private Type uPicDesc
        Size As Long
        Type As Long
        #If  VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
        #Else 
            hPic As Long
            hPal As Long
        #End  If
    End Type
    
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    
    #If  VBA7 Then
        Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As Any) As Long
        Private Declare PtrSafe Function SHCreateItemFromParsingName Lib "shell32" (ByVal pPath As LongPtr, ByVal pBC As Long, rIID As Any, ppV As Any) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
        Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
        Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
        Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
        Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    #Else 
        Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As Any) As Long
        Private Declare Function SHCreateItemFromParsingName Lib "shell32" (ByVal pPath As Long, ByVal pBC As Long, rIID As Any, ppV As Any) As Long
        Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
        Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
        Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
        Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    #End  If
    
    Private Enum vtbl_IShellItemImageFactory
        QueryInterface
        AddRef
        Release
        GetImage
    End Enum
    
    #If  Win64 Then
        Private Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage * 8
    #Else 
        Private Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage * 4
    #End  If
    
    Private Const CC_STDCALL As Long = 4
    Private Const S_OK = 0
    Private Const vbPicTypeBitmap = 1
    Private Const IID_IShellItemImageFactory = "{BCC18B79-BA16-442F-80C4-8A59C30C463B}"  
    
    
    Public Function ThumbnailPicFromFile(ByVal FilePath As String, Optional ByVal Width As Long = 32, Optional ByVal Height As Long = 32) As StdPicture
    
        #If  Win64 Then
            Static hBmp As LongPtr
            Dim pUnk As LongPtr
            Dim lPt As LongPtr
        #Else 
            Static hBmp As Long
            Dim pUnk As Long
        #End  If
    
        Dim lRet As Long, bIID(0 To 15) As Byte, Unk As IUnknown
        Dim tSize As Size, sFilePath As String
        
        DeleteObject hBmp
        If Len(Dir(FilePath, vbDirectory)) Then
            If CLSIDFromString(StrPtr(IID_IShellItemImageFactory), bIID(0)) = S_OK Then
                If SHCreateItemFromParsingName(StrPtr(FilePath), 0, bIID(0), Unk) = S_OK Then
                    pUnk = ObjPtr(Unk)
                    If pUnk Then
                        tSize.cx = Width: tSize.cy = Height
                        #If  Win64 Then
                            CopyMemory lPt, tSize, LenB(tSize)
                            If CallFunction_COM(pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, lPt, 0, VarPtr(hBmp)) = S_OK Then
                        #Else 
                            If CallFunction_COM(pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, tSize.cx, tSize.cy, 0, VarPtr(hBmp)) = S_OK Then
                        #End  If
                                If hBmp Then
                                    Set ThumbnailPicFromFile = PicFromBmp(hBmp)
                                End If
                            End If
                    End If
                End If
            End If
        End If
    
    End Function
    
    
    #If  VBA7 Then
        Private Function PicFromBmp(ByVal hBmp As LongPtr) As StdPicture
        Dim hLib As LongPtr
    #Else 
        Private Function PicFromBmp(ByVal hBmp As Long) As StdPicture
        Dim hLib As Long
    #End  If
        
        Dim uPicDesc As uPicDesc, IID_IPicture As GUID, oPicture As IPicture
        
        With uPicDesc
            .Size = Len(uPicDesc)
            .Type = vbPicTypeBitmap
            .hPic = hBmp
            .hPal = 0
        End With
        
        With IID_IPicture
            .Data1 = &H7BF80981
            .Data2 = &HBF32
            .Data3 = &H101A
            .Data4(0) = &H8B
            .Data4(1) = &HBB
            .Data4(3) = &HAA
            .Data4(5) = &H30
            .Data4(6) = &HC
            .Data4(7) = &HAB
        End With
        
        If OleCreatePictureIndirectAut(uPicDesc, IID_IPicture, True, oPicture) = S_OK Then
            Set PicFromBmp = oPicture
        End If
    
    End Function
    
    
    #If  VBA7 Then
        Private Function CallFunction_COM(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, _
        ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
        
        Dim vParamPtr() As LongPtr
    #Else 
        Private Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, _
        ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
        
        Dim vParamPtr() As Long
    #End  If
        
        Dim vParamType() As Integer
        Dim pIndex As Long, pCount As Long
        Dim vRtn As Variant, vParams() As Variant
    
        If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
        If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
        
        vParams() = FunctionParameters()
        pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
        
        If pCount = 0& Then
            ReDim vParamPtr(0 To 0)
            ReDim vParamType(0 To 0)
        Else
            ReDim vParamPtr(0 To pCount - 1&)
            ReDim vParamType(0 To pCount - 1&)
            For pIndex = 0& To pCount - 1&
                vParamPtr(pIndex) = VarPtr(vParams(pIndex))
                vParamType(pIndex) = VarType(vParams(pIndex))
            Next
        End If
                                                           
        pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0), vParamPtr(0), vRtn)
            
        If pIndex = 0& Then
            CallFunction_COM = vRtn
        Else
            SetLastError pIndex
        End If
     
    End Function


    2- Code usage example in a UserForm Module :

    (Adds the full paths of files and subfolders located in a parent folder to a listbox and their respective thumbnail are displayed on an image control as the file paths are selected )

    Code:
    Option Explicit
    
    #If  VBA7 Then
        Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    #Else 
        Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    #End  If
    
    Private Sub UserForm_Initialize()
    
        Dim FileSystem As Object, oSubFolder As Object, oFile As Object
        Dim oPic As StdPicture, sParentFolder As String
            
        Image1.PictureSizeMode = fmPictureSizeModeStretch
        Set FileSystem = CreateObject("Scripting.FileSystemObject")
        sParentFolder = "C:" '<== change parent folder as required.
        
        If FileSystem.FolderExists(sParentFolder) Then
            For Each oSubFolder In FileSystem.GetFolder(sParentFolder).SubFolders
                ListBox1.AddItem FileSystem.GetAbsolutePathName(oSubFolder)
            Next oSubFolder
            For Each oFile In FileSystem.GetFolder(sParentFolder).Files
                ListBox1.AddItem FileSystem.GetAbsolutePathName(oFile)
            Next
            If ListBox1.ListCount Then
                Set Image1.Picture = ThumbnailPicFromFile(ListBox1.List(0), 256, 256)
                ListBox1.Selected(0) = True
            End If
        End If
    
    End Sub
    
    
    Private Sub ListBox1_Change()
        Set Image1.Picture = ThumbnailPicFromFile(ListBox1.Value, 256, 256)
    End Sub
    
    Private Sub CommandButton1_Click()
        Call OpenItem
    End Sub
    
    Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
        Call OpenItem
    End Sub
    
    Private Sub OpenItem()
        Call ShellExecute(Application.hwnd, "Open", ListBox1.Value, vbNullString, vbNullString, 1)
    End Sub

    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  2. #2
    Board Regular
    Join Date
    Nov 2018
    Posts
    202
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Extract Thumbnail preview from file

    Great!

  3. #3
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,347
    Post Thanks / Like
    Mentioned
    39 Post(s)
    Tagged
    3 Thread(s)

    Default Re: Extract Thumbnail preview from file

    Quote Originally Posted by yinkajewole View Post
    Great!
    Glad you liked it !

    Out of interest and just so that I know if this works as expected accross different platforms - Can you please, tell me on which version of excel you have tried the code ? and on which edition of Windows as well ? (including bitness of excel and windows ie: 32 or 64 bits)

    Regards.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  4. #4
    Board Regular
    Join Date
    Nov 2018
    Posts
    202
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Extract Thumbnail preview from file

    this might be off-topic but please pardon me.
    i have some files of a particular software that are saved with its higher version, so windows explorer do not get their actual thumbnails, hence it replaces the thumbnails with its software icon. But i could find the thumbnail bmp file when i rename the file extension to zip.
    so, do you also have an idea how to extract the bmp from this type of files and set it into an image box on a userform?

  5. #5
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,347
    Post Thanks / Like
    Mentioned
    39 Post(s)
    Tagged
    3 Thread(s)

    Default Re: Extract Thumbnail preview from file

    so, do you also have an idea how to extract the bmp from this type of files and set it into an image box on a userform?
    That's difficult because all what the code does is just to extract whatever bmp windows explorer happens to be displaying.

    So, I am afraid, the answer to your question is I don't know.

    Regards.
    Last edited by Jaafar Tribak; Jun 4th, 2019 at 03:09 AM.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  6. #6
    New Member
    Join Date
    Jun 2018
    Posts
    43
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Extract Thumbnail preview from file

    This is great! In my use case I would need to display the preview of the file, then rename the file, and continue to the next until looped through all of the files in a folder. Any ideas?

    Thank you!

  7. #7
    Board Regular
    Join Date
    Nov 2018
    Posts
    202
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Extract Thumbnail preview from file

    Quote Originally Posted by Jaafar Tribak View Post
    Glad you liked it !

    Out of interest and just so that I know if this works as expected accross different platforms - Can you please, tell me on which version of excel you have tried the code ? and on which edition of Windows as well ? (including bitness of excel and windows ie: 32 or 64 bits)

    Regards.
    i used ms office excel 2013, 32 bit, win 7
    Last edited by yinkajewole; Jun 7th, 2019 at 03:17 PM.

  8. #8
    Board Regular
    Join Date
    Nov 2018
    Posts
    202
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Extract Thumbnail preview from file

    Quote Originally Posted by Jaafar Tribak View Post
    That's difficult because all what the code does is just to extract whatever bmp windows explorer happens to be displaying.

    So, I am afraid, the answer to your question is I don't know.

    Regards.
    no problem if you don't know. but i've seen someone who did it in vba of another software, it's just that i'm not experienced enough to edit the code for my use

  9. #9
    New Member
    Join Date
    Jun 2018
    Posts
    43
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Extract Thumbnail preview from file

    Would it be possible to show the file preview rather than the thumbnail?

  10. #10
    Board Regular
    Join Date
    Aug 2012
    Posts
    252
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Extract Thumbnail preview from file

    Dear Jaafar,

    Works great on Windows 10 (64 bit) and Office 365 (32 bit).

    Many thanks for sharing.

    Kind Regards,
    Post a smaller screen shot: MrExcel HTML Maker.
    Code tags for posting code
    Test screen shot, codes etc: here

    Excel 2010 (32-bit) and Office 365
    (32-bit)

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

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