Option Explicit

Private Const MAX_PATH = 260
Private Const SHGFI_ICON = &H100

Private Type PICTDESC
  cbSizeofStruct As Long
  PicType As Long
  hImage As Long
  xExt As Long
  yExt As Long
End Type

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

Private Declare Function OleCreatePictureIndirect Lib _
      "olepro32.dll" (ByRef pPictDesc As PICTDESC, _
      ByRef riid As GUID, ByVal fOwn As Long, _
      ByRef ppvObj As IPictureDisp) As Long

Private Declare Function ExtractIcon Lib "shell32.dll" Alias _
      "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName _
      As String, ByVal nIconIndex As Long) As Long

Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias _
      "SHGetFileInfoA" (ByVal pszPath As String, ByVal _
      dwFileAttributes As Long, psfi As SHFILEINFO, ByVal _
      cbFileInfo As Long, ByVal uFlags As Long) As Long

Private Type SHFILEINFO
  hIcon As Long
  iIcon As Long
  dwAttributes As Long
  szDisplayName As String * MAX_PATH
  szTypeName As String * 80
End Type

Public Function PictureFromFile(ByVal vsFileName As String) _
      As Picture

  Dim SHFI As SHFILEINFO
  Dim PicTmp As Picture
  Dim PicDes As PICTDESC
  Dim IID_IDispatch As GUID

  SHGetFileInfo vsFileName, -1, SHFI, -1, SHGFI_ICON

  If SHFI.hIcon = 0 Then
    SHFI.hIcon = ExtractIcon(App.hInstance, "shell32.dll", 0)
  End If

  IID_IDispatch.Data1 = &H20400
  IID_IDispatch.Data4(0) = &HC0
  IID_IDispatch.Data4(7) = &H46

  PicDes.cbSizeofStruct = Len(PicDes)
  PicDes.PicType = vbPicTypeIcon
  PicDes.hImage = SHFI.hIcon

  OleCreatePictureIndirect PicDes, IID_IDispatch, True, PicTmp
  Set PictureFromFile = PicTmp
End Function

Public Function GetFileExtension(ByVal vsFileName As String) _
      As String

  Dim nPos As Long

  nPos = InStrRev(vsFileName, ".")
  If nPos <> 0 Then
    GetFileExtension = Mid(vsFileName, nPos + 1)
  End If
End Function

Option Explicit

Private Sub Form_Load()
  File1.Visible = False
  ListFilesInListView
End Sub

Private Sub Dir1_Change()
  File1.Path = Dir1.Path
  ListFilesInListView
End Sub

Private Sub ListFilesInListView()
  Dim strPath As String

  Dim intListCnt As Integer
  Dim astrFiles() As String
  Dim strFileExt As String
  Dim intImage As Integer
  Dim i As Integer, j As Integer

  Dim colDateiTypen As New Collection

  ListView1.ListItems.Clear
  Set ListView1.Icons = Nothing
  ImageList1.ListImages.Clear

  strPath = File1.Path
  If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"

  intListCnt = File1.ListCount - 1
  If intListCnt > -1 Then
    Screen.MousePointer = vbHourglass

    ReDim astrFiles(1, intListCnt)
    For i = 0 To intListCnt
      intImage = 0
      strFileExt = GetFileExtension(strPath & File1.List(i))

      If Len(strFileExt) > 0 Then
        If UCase(strFileExt) <> UCase("EXE") Then
          For j = 1 To colDateiTypen.Count
            If UCase(strFileExt) = UCase(colDateiTypen(j)) Then
              intImage = j
              Exit For
            End If
          Next j
        End If
      End If

      If intImage = 0 Then
        If Len(strFileExt) > 0 Then
          colDateiTypen.Add strFileExt
        End If

         ImageList1.ListImages.Add , , _
               PictureFromFile(strPath & File1.List(i))
         intImage = ImageList1.ListImages.Count
      End If

      astrFiles(0, i) = File1.List(i)
      astrFiles(1, i) = intImage
    Next i

    Set ListView1.Icons = ImageList1
    For i = 0 To intListCnt
      ListView1.ListItems.Add , , astrFiles(0, i), _
                  CInt(astrFiles(1, i))
    Next i
  End If
  Screen.MousePointer = vbDefault
  Erase astrFiles
End Sub

Private Sub Form_Terminate()
  Set ListView1.Icons = Nothing
End Sub