Imports System.IO
Imports System.Runtime.InteropServices
Public Class Form1

    Private FileNames As New List(Of FileInfo)
    Private Cache As New Dictionary(Of Integer, ListViewItem)

    Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
        ListView1.View = View.LargeIcon
        ListView1.LargeImageList = ImageList1
        ListView1.VirtualMode = True
        ListView1.VirtualListSize = 0

        ImageList1.ImageSize = New Size(100, 100)
        ImageList1.ColorDepth = ColorDepth.Depth32Bit
    End Sub

    Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
        Using folder As New FolderBrowserDialog
            If folder.ShowDialog = Windows.Forms.DialogResult.OK Then
                Cache.Clear()
                ListView1.Items.Clear()
                ImageList1.Images.Clear()

                Dim di As New DirectoryInfo(folder.SelectedPath)
                FileNames.Clear()
                For Each fi As FileInfo In di.GetFiles
                    Select Case fi.Extension.ToUpper
                        Case ".BMP", ".JPG", ".PNG", ".GIF"
                            FileNames.Add(fi)
                    End Select
                Next

                ListView1.VirtualListSize = FileNames.Count
                ListView1.Refresh()
            End If
        End Using
    End Sub

    Private Sub listView1_RetrieveVirtualItem(ByVal sender As Object, ByVal e As RetrieveVirtualItemEventArgs) Handles ListView1.RetrieveVirtualItem
        If Cache.ContainsKey(e.ItemIndex) Then
            e.Item = Cache(e.ItemIndex)
        ElseIf e.ItemIndex < FileNames.Count Then
            Dim FullFileName As String = FileNames(e.ItemIndex).FullName
            ImageList1.Images.Add(Shell.GetThumbnailImage(FullFileName, 100, 32))
            Dim LVI As New ListViewItem(FileNames(e.ItemIndex).Name, ImageList1.Images.Count - 1)
            Cache.Add(e.ItemIndex, LVI)
            e.Item = LVI
        End If
    End Sub

End Class

Public Class Shell

    Public Shared Function GetThumbnailImage(ByVal fileName As String, _
  ByVal longestEdge As Integer, ByVal colorDepth As Integer) As Image

        Dim desktopFolder As IShellFolder = Nothing
        Dim someFolder As IShellFolder = Nothing
        Dim extract As IExtractImage = Nothing
        Dim pidl As IntPtr
        Dim filePidl As IntPtr

        Const MAX_PATH As Integer = 260

        'Manually define the IIDs for IShellFolder and IExtractImage
        Dim IID_IShellFolder = New Guid("000214E6-0000-0000-C000-000000000046")
        Dim IID_IExtractImage = New Guid("BB2E617C-0920-11d1-9A0B-00C04FC2D6C1")

        'Divide the file name into a path and file name
        Dim folderName = Path.GetDirectoryName(fileName)
        Dim shortFileName = Path.GetFileName(fileName)

        'Get the desktop IShellFolder
        ShellInterop.SHGetDesktopFolder(desktopFolder)

        'Get the parent folder IShellFolder
        desktopFolder.ParseDisplayName(IntPtr.Zero, IntPtr.Zero, folderName, 0, pidl, 0)
        desktopFolder.BindToObject(pidl, IntPtr.Zero, IID_IShellFolder, someFolder)

        'Get the file's IExtractImage
        someFolder.ParseDisplayName(IntPtr.Zero, IntPtr.Zero, shortFileName, 0, filePidl, 0)
        someFolder.GetUIObjectOf(IntPtr.Zero, 1, filePidl, IID_IExtractImage, 0, extract)

        'Set the size
        Dim size As SIZE_API_STRUCTURE
        size.cx = 500
        size.cy = 500

        Dim flags = IEIFLAG.ORIGSIZE ' Or IEIFLAG.QUALITY
        Dim bmp As IntPtr
        Dim thePath = Marshal.AllocHGlobal(MAX_PATH)

        'Interop will throw an exception if one of these calls fail.
        Try
            extract.GetLocation(thePath, MAX_PATH, 0, size, colorDepth, flags)
            extract.Extract(bmp)
        Catch ex As Exception
        End Try


        'Free the global memory we allocated for the path string
        Marshal.FreeHGlobal(thePath)

        'Free the pidls. The Runtime Callable Wrappers 
        'should automatically release the COM objects
        Marshal.FreeCoTaskMem(pidl)
        Marshal.FreeCoTaskMem(filePidl)

        If Not bmp.Equals(IntPtr.Zero) Then
            GetThumbnailImage = Image.FromHbitmap(bmp)
        Else
            GetThumbnailImage = Nothing
        End If
    End Function

End Class

Public Enum IEIFLAG As Integer
    ASYNC = &H1
    CACHE = &H2
    ASPECT = &H4
    OFFLINE = &H8
    GLEAM = &H10
    SCREEN = &H20
    ORIGSIZE = &H40
    NOSTAMP = &H80
    NOBORDER = &H100
    QUALITY = &H200
End Enum

<StructLayout(LayoutKind.Sequential)> _
Public Structure STRRET_CSTR
    Public uType As Integer
    <FieldOffset(4), MarshalAs(UnmanagedType.LPWStr)> _
    Public pOleStr As String
    <FieldOffset(4)> _
    Public uOffset As Integer
    <FieldOffset(4), MarshalAs(UnmanagedType.ByValArray, SizeConst:=520)> _
    Public strName As Byte()
End Structure

<StructLayout(LayoutKind.Sequential)> _
Public Structure SIZE_API_STRUCTURE
    Public cx As Integer
    Public cy As Integer
End Structure

<ComImportAttribute(), _
 GuidAttribute("BB2E617C-0920-11d1-9A0B-00C04FC2D6C1"), _
 InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IExtractImage

    Sub GetLocation( _
        ByVal pszPathBuffer As IntPtr, _
        ByVal cch As Integer, _
        ByRef pdwPriority As Integer, _
        ByRef prgSize As SIZE_API_STRUCTURE, _
        ByVal dwRecClrDepth As Integer, _
        ByRef pdwFlags As Integer)

    Sub Extract(ByRef phBmpThumbnail As IntPtr)

End Interface

<ComImportAttribute(), _
GuidAttribute("000214E6-0000-0000-C000-000000000046"), _
InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IShellFolder

    Sub ParseDisplayName( _
      ByVal hWnd As IntPtr, _
      ByVal pbc As IntPtr, _
      ByVal pszDisplayName As String, _
      ByRef pchEaten As Integer, _
      ByRef ppidl As System.IntPtr, _
      ByRef pdwAttributes As Integer)

    Sub EnumObjects( _
      ByVal hwndOwner As IntPtr, _
      <MarshalAs(UnmanagedType.U4)> ByVal grfFlags As Integer, _
      <Out()> ByRef ppenumIDList As IntPtr)

    Sub BindToObject( _
      ByVal pidl As IntPtr, _
      ByVal pbcReserved As IntPtr, _
      ByRef riid As Guid, _
      ByRef ppvOut As IShellFolder)

    Sub BindToStorage( _
      ByVal pidl As IntPtr, _
      ByVal pbcReserved As IntPtr, _
      ByRef riid As Guid, _
      <Out()> ByVal ppvObj As IntPtr)

    <PreserveSig()> _
    Function CompareIDs( _
    ByVal lParam As IntPtr, _
    ByVal pidl1 As IntPtr, _
    ByVal pidl2 As IntPtr) As Integer

    Sub CreateViewObject( _
      ByVal hwndOwner As IntPtr, _
      ByRef riid As Guid, _
      ByVal ppvOut As Object)

    Sub GetAttributesOf( _
      ByVal cidl As Integer, _
      ByVal apidl As IntPtr, _
      <MarshalAs(UnmanagedType.U4)> ByRef rgfInOut As Integer)

    Sub GetUIObjectOf( _
      ByVal hwndOwner As IntPtr, _
      ByVal cidl As Integer, _
      ByRef apidl As IntPtr, _
      ByRef riid As Guid, _
      <Out()> ByVal prgfInOut As Integer, _
      <Out(), MarshalAs(UnmanagedType.IUnknown)> ByRef ppvOut As Object)

    Sub GetDisplayNameOf( _
      ByVal pidl As IntPtr, _
      <MarshalAs(UnmanagedType.U4)> ByVal uFlags As Integer, _
      ByRef lpName As STRRET_CSTR)

    Sub SetNameOf( _
      ByVal hwndOwner As IntPtr, _
      ByVal pidl As IntPtr, _
      <MarshalAs(UnmanagedType.LPWStr)> ByVal lpszName As String, _
      <MarshalAs(UnmanagedType.U4)> ByVal uFlags As Integer, _
      ByRef ppidlOut As IntPtr)

End Interface

Public Class ShellInterop
    <DllImport("shell32.dll", CharSet:=CharSet.Auto)> _
    Public Shared Function SHGetDesktopFolder( _
    <Out()> ByRef ppshf As IShellFolder) As Integer
    End Function
End Class

Select all