# Extract Thumbnail preview from file



## Jaafar Tribak (Jun 2, 2019)

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:

```
Option Explicit

Type Size
    cx As Long
    cy As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hPic As Long
        hPal As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Enum vtbl_IShellItemImageFactory
    QueryInterface
    AddRef
    Release
    GetImage
End Enum

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
    Private Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage * 8
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage * 4
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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

    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Static hBmp As LongPtr
        Dim pUnk As LongPtr
        Dim lPt As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Static hBmp As Long
        Dim pUnk As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
                        CopyMemory lPt, tSize, LenB(tSize)
                        If CallFunction_COM(pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, lPt, 0, VarPtr(hBmp)) = S_OK Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
                        If CallFunction_COM(pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, tSize.cx, tSize.cy, 0, VarPtr(hBmp)) = S_OK Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
                            If hBmp Then
                                Set ThumbnailPicFromFile = PicFromBmp(hBmp)
                            End If
                        End If
                End If
            End If
        End If
    End If

End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function PicFromBmp(ByVal hBmp As LongPtr) As StdPicture
    Dim hLib As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function PicFromBmp(ByVal hBmp As Long) As StdPicture
    Dim hLib As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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 ) 


```
Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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:" [B][COLOR=#008000]'<== change parent folder as required.[/COLOR][/B]
    
    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
```


----------



## yinkajewole (Jun 3, 2019)

Great!


----------



## Jaafar Tribak (Jun 3, 2019)

yinkajewole said:


> 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.


----------



## yinkajewole (Jun 3, 2019)

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?


----------



## Jaafar Tribak (Jun 4, 2019)

> 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.


----------



## scotsrule08 (Jun 7, 2019)

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!


----------



## yinkajewole (Jun 7, 2019)

Jaafar Tribak said:


> 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


----------



## yinkajewole (Jun 7, 2019)

Jaafar Tribak said:


> 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


----------



## scotsrule08 (Jun 7, 2019)

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


----------



## KeepTrying (Jun 24, 2019)

Dear Jaafar,

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

Many thanks for sharing.

Kind Regards,


----------



## Jaafar Tribak (Jun 2, 2019)

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:

```
Option Explicit

Type Size
    cx As Long
    cy As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hPic As Long
        hPal As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Enum vtbl_IShellItemImageFactory
    QueryInterface
    AddRef
    Release
    GetImage
End Enum

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
    Private Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage * 8
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage * 4
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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

    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Static hBmp As LongPtr
        Dim pUnk As LongPtr
        Dim lPt As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Static hBmp As Long
        Dim pUnk As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
                        CopyMemory lPt, tSize, LenB(tSize)
                        If CallFunction_COM(pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, lPt, 0, VarPtr(hBmp)) = S_OK Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
                        If CallFunction_COM(pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, tSize.cx, tSize.cy, 0, VarPtr(hBmp)) = S_OK Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
                            If hBmp Then
                                Set ThumbnailPicFromFile = PicFromBmp(hBmp)
                            End If
                        End If
                End If
            End If
        End If
    End If

End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function PicFromBmp(ByVal hBmp As LongPtr) As StdPicture
    Dim hLib As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function PicFromBmp(ByVal hBmp As Long) As StdPicture
    Dim hLib As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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 ) 


```
Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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:" [B][COLOR=#008000]'<== change parent folder as required.[/COLOR][/B]
    
    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
```


----------



## Jaafar Tribak (Jun 24, 2019)

KeepTrying said:


> Dear Jaafar,
> 
> Works great on Windows 10 (64 bit) and Office 365 (32 bit).
> 
> ...



Thanks KeepTrying for the feedback.

Regards.


----------



## yinkajewole (Jul 8, 2019)

Jaafar Tribak said:


> 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 just tried it on Win Xp, Excel 2010. There was an error 
"Can't find DLL entry point SHCreateItemFromParsingName in shell32"
Any workaround?


----------



## Jaafar Tribak (Jul 9, 2019)

@yinkajewole

According to the MS documentation, the Shell32 library doesn't contain the SHCreateItemFromParsingName function on Win XP.... The function is only avalable on Vista and later.

There is this alternative api in the shell32 dll which is called *ILCreateFromPathW* and which I think could be used instead in order to make the code work on win xp.

I haven't tested it yet but I'll give it a try and post back if successful.

Regards.


----------



## Jaafar Tribak (Jul 9, 2019)

EDIT previous post:

I meant to say the *SHCreateItemFromIDList* API (not the ILCreateFromPathW) .

Unfortunately, that API also works on Vista and later only so it won't solve the problem.

I'll investigate this further and if anything comes up I'll let you know.

Regards.


----------



## yinkajewole (Jul 9, 2019)

ok


----------



## Jaafar Tribak (Jul 10, 2019)

yinkajewole said:


> I just tried it on Win Xp, Excel 2010. There was an error
> "Can't find DLL entry point SHCreateItemFromParsingName in shell32"
> Any workaround?



Ok - after some further research and reading, I realised that the SHCreateItemFromParsingName as well as SHCreateItemFromIDList APIs do not work on vista or win7 either... They only work on win8 and later.

In XP, we need to use the IShellFolder and IExtractImage interfaces instead of the IShellItemImageFactory.

Again, I use here the handy CallFunction_COM routine to avoid the need for having a seperate typelib file and referencing it in the vbaproject.

Here is a workbook demo 


Below is the code for extracting Files & folder thumbnails in *win xp*.

*1*- Code in a Standard Module:

```
Option Explicit

Private Type Size
    cx As Long
    cy As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        hPic As Long
        hPal As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As Any) As Long
    Private Declare PtrSafe Function SHGetDesktopFolder Lib "Shell32.dll" (ByRef ppshf As IUnknown) As Long
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)
    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
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As Any) As Long
    Private Declare Function SHGetDesktopFolder Lib "Shell32.dll" (ByRef ppshf As IUnknown) As Long
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem 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
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
    Const PTR_LEN = 8
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Const PTR_LEN = 4
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const IShellFolder_ParseDisplayName_VtblOffset = 3
Private Const IShellFolder_BindToObject_VtblOffset = 5
Private Const IShellFolder_GetUIObjectOf_VtblOffset = 10
Private Const IExtractImage_GetLocation_VtblOffset = 3
Private Const IExtractImage_Extract_VtblOffset = 4
Private Const IUnknownRelease_VtblOffset = 8

Private Const IEIFLAG_NOBORDER = &H100
Private Const IEIFLAG_SCREEN = &H20
Private Const IEIFLAG_OFFLINE = &H8
Private Const MAX_PATH = 260

Private Const CC_STDCALL As Long = 4
Private Const S_OK = 0
Private Const vbPicTypeBitmap = 1



Public Function ThumbnailPicFromFile(ByVal FilePath As String, Optional ByVal Width As Long = 32, Optional ByVal Height As Long = 32) As StdPicture

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
        Static hBmp As LongPtr
        Dim pUnk As LongPtr
        Dim lPt As LongPtr
        Dim lPidl As LongPtr, lFilePidl As LongPtr
        Dim lFolder As LongPtr, lExtractImage As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Static hBmp As Long
        Dim pUnk As Long
        Dim lPidl As Long, lFilePidl As Long
        Dim lFolder As Long, lExtractImage As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim DesktopFolder As IUnknown
    Dim tSize As Size
    Dim bIID1(0 To 15) As Byte, bIID2(0 To 15) As Byte
    Dim sFolderName As String, sPathBuff As String
    
    Call DeleteObject(hBmp)
    sPathBuff = String(MAX_PATH, 0)
    tSize.cx = Width
    tSize.cy = Height
    
    If Len(Dir(FilePath, vbDirectory + vbNormal)) Then
        sFolderName = Left(FilePath, InStrRev(FilePath, "") - 1)
        FilePath = Mid(FilePath, InStrRev(FilePath, "") + 1)
        Call CLSIDFromString(StrPtr("{000214E6-0000-0000-C000-000000000046}"), bIID1(0))
        Call CLSIDFromString(StrPtr("{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}"), bIID2(0))
        Call SHGetDesktopFolder(DesktopFolder)
        pUnk = ObjPtr(DesktopFolder)
        If pUnk Then
            If CallFunction_COM(pUnk, IShellFolder_ParseDisplayName_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, 0, 0, sFolderName, 0, VarPtr(lPidl), 0) = S_OK Then
                If CallFunction_COM(pUnk, IShellFolder_BindToObject_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, lPidl, 0, VarPtr(bIID1(0)), VarPtr(lFolder)) = S_OK Then
                    If CallFunction_COM(lFolder, IShellFolder_ParseDisplayName_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, 0, 0, FilePath, 0, VarPtr(lFilePidl), 0) = S_OK Then
                        If CallFunction_COM(lFolder, IShellFolder_GetUIObjectOf_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, 0, 1, VarPtr(lFilePidl), VarPtr(bIID2(0)), 0&, VarPtr(lExtractImage)) = S_OK Then
                            [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
                                CopyMemory lPt, tSize, LenB(tSize)
                                If CallFunction_COM(lExtractImage, IExtractImage_GetLocation_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, sPathBuff, MAX_PATH, 0, VarPtr(lPt), 32, IEIFLAG_NOBORDER Or IEIFLAG_SCREEN Or IEIFLAG_OFFLINE) = S_OK Then
                            [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
                                If CallFunction_COM(lExtractImage, IExtractImage_GetLocation_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, sPathBuff, MAX_PATH, 0, VarPtr(tSize.cx), VarPtr(tSize.cy), 32, IEIFLAG_NOBORDER Or IEIFLAG_SCREEN Or IEIFLAG_OFFLINE) = S_OK Then
                            [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
                                If CallFunction_COM(lExtractImage, IExtractImage_Extract_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, VarPtr(hBmp)) = S_OK Then
                                    Set ThumbnailPicFromFile = PicFromBmp(hBmp)
                                    CallFunction_COM lExtractImage, IUnknownRelease_VtblOffset, vbLong, CC_STDCALL
                                    CallFunction_COM lFolder, IUnknownRelease_VtblOffset, vbLong, CC_STDCALL
                                    CallFunction_COM pUnk, IUnknownRelease_VtblOffset, vbLong, CC_STDCALL
                                    Call CoTaskMemFree(lPidl)
                                    Call CoTaskMemFree(lFilePidl)
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If

End Function


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Public Function PicFromBmp(ByVal hBmp As LongPtr) As StdPicture
    Dim hLib As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Public Function PicFromBmp(ByVal hBmp As Long) As StdPicture
    Dim hLib As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  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


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  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
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    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
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  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 in the UserForm Module:

```
Option Explicit

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  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
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    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
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  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
```

I don't have Win xp so I didn't have a chance to test the code .

I wrote and tested the code on Win 10 and noticed that it only works for displaying folder thumbs  but fails to extract some file thumbs such as pdf, mp4, doc files etc...

Can you, or anyone else, please test the code on XP and let me know how it works (specially with file thumbs).

Regards.


----------



## yinkajewole (Jul 11, 2019)

It did not extract the thumbs of all the folders. The is only file I saw file working is pdf. Above all, it is somehow slow unlike the first one you did.


----------



## Jaafar Tribak (Jul 11, 2019)

yinkajewole said:


> It did not extract the thumbs of all the folders. The is only file I saw file working is pdf. Above all, it is somehow slow unlike the first one you did.



On my machine, it displays thumbs for image files and for folders only.

Based on my recent research on the subject, the correct shell interfaces for extracting thumbnails change from one version of windows to the next plus they don't seem to work as expected on many file extentions.

Anyway, try the following variation of the ThumbnailPicFromFile function and see if it is any good on xp :

```
Public Function ThumbnailPicFromFile(ByVal FilePath As String, Optional ByVal Width As Long = 32, Optional ByVal Height As Long = 32) As StdPicture

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
        Static hBmp As LongPtr
        Dim pUnk As LongPtr
        Dim lPt As LongPtr
        Dim lPidl As LongPtr, lFilePidl As LongPtr
        Dim lFolder As LongPtr, lExtractImage As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Static hBmp As Long
        Dim pUnk As Long
        Dim lPt As Long
        Dim lPidl As Long, lFilePidl As Long
        Dim lFolder As Long, lExtractImage As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim DesktopFolder As IUnknown
    Dim tSize As Size
    Dim bIID1(0 To 15) As Byte, bIID2(0 To 15) As Byte
    Dim sFolderName As String, sPathBuff As String
    
    Call DeleteObject(hBmp)
    sPathBuff = String(MAX_PATH + 1, 0)
    tSize.cx = Width
    tSize.cy = Height
    
    sFolderName = Left(FilePath, InStrRev(FilePath, "") - 1)
    FilePath = Mid(FilePath, InStrRev(FilePath, "") + 1)
    Call CLSIDFromString(StrPtr("{000214E6-0000-0000-C000-000000000046}"), bIID1(0))
    Call CLSIDFromString(StrPtr("{BB2E617C-0920-11d1-9A0B-00C04FC2D6C1}"), bIID2(0))
    Call SHGetDesktopFolder(DesktopFolder)
    pUnk = ObjPtr(DesktopFolder)
    
    If pUnk Then
        If CallFunction_COM(pUnk, IShellFolder_ParseDisplayName_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, 0, 0, sFolderName, 0, VarPtr(lPidl), 0) = S_OK Then
            If CallFunction_COM(pUnk, IShellFolder_BindToObject_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, lPidl, 0, VarPtr(bIID1(0)), VarPtr(lFolder)) = S_OK Then
                If CallFunction_COM(lFolder, IShellFolder_ParseDisplayName_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, 0, 0, FilePath, 0, VarPtr(lFilePidl), 0) = S_OK Then
                    If CallFunction_COM(lFolder, IShellFolder_GetUIObjectOf_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, 0, 1, VarPtr(lFilePidl), VarPtr(bIID2(0)), 0&, VarPtr(lExtractImage)) = S_OK Then
                        CopyMemory lPt, tSize, LenB(tSize)
                        If CallFunction_COM(lExtractImage, IExtractImage_GetLocation_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, sPathBuff, MAX_PATH, 0, VarPtr(lPt), 32, IEIFLAG_NOBORDER Or IEIFLAG_SCREEN Or IEIFLAG_OFFLINE) = S_OK Then
                            If CallFunction_COM(lExtractImage, IExtractImage_Extract_VtblOffset * PTR_LEN, vbLong, CC_STDCALL, VarPtr(hBmp)) = S_OK Then
                                Set ThumbnailPicFromFile = PicFromBmp(hBmp)
                                CallFunction_COM lExtractImage, IUnknownRelease_VtblOffset, vbLong, CC_STDCALL
                                CallFunction_COM lFolder, IUnknownRelease_VtblOffset, vbLong, CC_STDCALL
                                CallFunction_COM pUnk, IUnknownRelease_VtblOffset, vbLong, CC_STDCALL
                                Call CoTaskMemFree(lPidl)
                                Call CoTaskMemFree(lFilePidl)
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
    
End Function
```


----------



## yinkajewole (Jul 11, 2019)

the CopyMemory function was not defined for 32bit, though I fixed it.

```
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
```
This did not even show any thumbs at all.
However, I notice the previous one shows .pptx and .pdf extensions. But the .pptx was faster in extraction that .pdf


----------



## yinkajewole (Aug 2, 2019)

@Jaafar Tribak  Since you do not have a solution for win xp, how can the code be altered to work on Win 7 and above?


----------



## Jaafar Tribak (Jun 2, 2019)

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:

```
Option Explicit

Type Size
    cx As Long
    cy As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hPic As Long
        hPal As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Enum vtbl_IShellItemImageFactory
    QueryInterface
    AddRef
    Release
    GetImage
End Enum

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
    Private Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage * 8
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Const VTBL_OFFSET = vtbl_IShellItemImageFactory.GetImage * 4
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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

    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Static hBmp As LongPtr
        Dim pUnk As LongPtr
        Dim lPt As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Static hBmp As Long
        Dim pUnk As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
                        CopyMemory lPt, tSize, LenB(tSize)
                        If CallFunction_COM(pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, lPt, 0, VarPtr(hBmp)) = S_OK Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
                        If CallFunction_COM(pUnk, VTBL_OFFSET, vbLong, CC_STDCALL, tSize.cx, tSize.cy, 0, VarPtr(hBmp)) = S_OK Then
                    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
                            If hBmp Then
                                Set ThumbnailPicFromFile = PicFromBmp(hBmp)
                            End If
                        End If
                End If
            End If
        End If
    End If

End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function PicFromBmp(ByVal hBmp As LongPtr) As StdPicture
    Dim hLib As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function PicFromBmp(ByVal hBmp As Long) As StdPicture
    Dim hLib As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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 ) 


```
Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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:" [B][COLOR=#008000]'<== change parent folder as required.[/COLOR][/B]
    
    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
```


----------



## SOULOUKALE (Dec 1, 2022)

work great! is it possible to preview the windows preview instead of the "standard" file icon ? thanks!


----------



## Jaafar Tribak (Dec 2, 2022)

SOULOUKALE said:


> work great! is it possible to preview the windows preview instead of the "standard" file icon ? thanks!
> 
> 
> View attachment 79987 View attachment 79988



@SOULOUKALE

I will take a fresh stab at this when I have time and see if the results are more consistent.

Thanks.


----------



## SOULOUKALE (Dec 2, 2022)

Jaafar Tribak said:


> @SOULOUKALE
> 
> I will take a fresh stab at this when I have time and see if the results are more consistent.
> 
> Thanks.



Thanks Jaafar, 

At the moment I have this code that does kind what I need 

With ActiveSheet.OLEObjects.Add( _
     Filename:="path_of_my_file", _
     Link:=False, _
     DisplayAsIcon:=True, _
     Top:=ActiveCell.Top, _
     Left:=ActiveCell.Left)
         .ShapeRange.LockAspectRatio = msoFalse
         .Height = 100
         .Width = 100
End With

this code seems to display the "Details" Icon from the file (IMG1) but I need to display the "Large icons" (IMG2).


----------



## Jaafar Tribak (Dec 2, 2022)

SOULOUKALE said:


> Thanks Jaafar,
> 
> At the moment I have this code that does kind what I need
> 
> ...


Have you tried with ?


```
With ActiveSheet.OLEObjects.Add( _
Filename:="path_of_my_file", _
Link:=False, _
DisplayAsIcon:=*False*, _
Top:=ActiveCell.Top, _
Left:=ActiveCell.Left)
.ShapeRange.LockAspectRatio = msoFalse
.Height = 100
.Width = 100
End With
```


----------



## SOULOUKALE (Dec 5, 2022)

Jaafar Tribak said:


> Have you tried with ?
> 
> 
> ```
> ...


I have already tried but it sill displays it as an icon . Maybe it is impossible with this method. Thanks for the help!


----------

