Extract Thumbnail preview from file

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,779
Office Version
  1. 2016
Platform
  1. Windows
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
    [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 )

Code: 
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


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


1669901676291.png
1669901699657.png
 
Upvote 0

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
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.
Click to expand...

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

Attachments

  • IMG1.png
    IMG1.png
    46.5 KB · Views: 12
  • IMG2.png
    IMG2.png
    65.6 KB · Views: 12
Upvote 0
SOULOUKALE said:
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).
Click to expand...
Have you tried with ?

Rich (BB code): 
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
 
Upvote 0
Jaafar Tribak said:
Have you tried with ?

Rich (BB code): 
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
Click to expand...
I have already tried but it sill displays it as an icon :(. Maybe it is impossible with this method. Thanks for the help!
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
Controlling the System Sounds (Warnings, Notifications etc) via CoreAudio Interfaces.
Replies
1
Views
69
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Referencing all Running Instances Of Excel, Word and Access
2 3 4
Replies
32
Views
1K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
MsgBox that waits for user input
2
Replies
14
Views
1K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Custom Accessibility Class
Replies
4
Views
1K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
VBA MsgBox customized to display data in tabular format _ (Data arranged in straight rows and columns)
Replies
5
Views
1K
Jaafar Tribak
Jaafar Tribak

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top