Startseite / Tipps / VB 5/6-Tipp 0281: Listview als Exploreransicht

VB 5/6-Tipp 0281: Listview als Exploreransicht

 von ActiveVB

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
' Die Komponente 'Microsoft Windows Common Controls 5.0 (SP2) (COMCTL32.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Listenansichtsetuerelement "ListView1"
' Steuerelement: Optionsfeld-Steuerelement "Option1" (Index von 0 bis 3)
' Steuerelement: Verzeichnisauswahlliste "Dir1"
' Steuerelement: Festplattenauswahlliste "Drive1"
' Steuerelement: Bilderliste "ImageList2"
' Steuerelement: Bilderliste "ImageList1"
'Dieser Source stammt von http://www.ActiveVB.de

'Sollten Sie Fehler entdecken oder Fragen haben, dann
'mailen Sie mir bitte unter: Reinecke@ActiveVB.de

Option Explicit

Option Compare Text

Private Declare Function FindFirstFile Lib "kernel32" Alias _
        "FindFirstFileA" (ByVal lpFileName As String, _
        lpFindFileData As WIN32_FIND_DATA) As Long
        
Private Declare Function FindNextFile Lib "kernel32" Alias _
        "FindNextFileA" (ByVal hFindFile As Long, _
        lpFindFileData As WIN32_FIND_DATA) As Long
        
Private Declare Function FindClose Lib "kernel32" (ByVal _
        hFindFile As Long) As Long
        
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias _
        "SHGetFileInfoA" (ByVal pszPath As String, ByVal _
        dwFileAttributes As Long, psfi As ShellFileInfoType, ByVal _
        cbFileInfo As Long, ByVal uFlags As Long) As Long

Private Declare Function FileTimeToSystemTime Lib "kernel32" _
        (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) _
        As Long
        
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" _
        (pDicDesc As IconType, riid As CLSIdType, ByVal fown As Long, _
        lpUnk As Object) As Long
        

Const SHGFI_TYPENAME = &H400&
Const MAX_PATH = 259
Const Large = &H100
Const Small = &H101

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type

Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_COMPRESSED = &H800
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100

Private Type SYSTEMTIME
  wYear As Integer
  wMonth As Integer
  wDayOfWeek As Integer
  wDay As Integer
  wHour As Integer
  wMinute As Integer
  wSecond As Integer
  wMilliseconds As Integer
End Type

Private Type IconType
  cbSize As Long
  picType As PictureTypeConstants
  hIcon As Long
End Type

Private Type CLSIdType
  id(16) As Byte
End Type

Private Type ShellFileInfoType
  hIcon As Long
  iIcon As Long
  dwAttributes As Long
  szDisplayName As String * 260
  szTypeName As String * 80
End Type

Private Type FileType
  Name As String
  Ext As String
  IcoIndex As Integer
End Type

Private Type DIRLISTTYPE
  Ext As String
  File As String
  Type As String
  Attributes As Long
  FileLen As Long
  LastWrite As FILETIME
End Type

Dim DirList() As DIRLISTTYPE

Private Sub Form_Load()
  Dim TPX&
  
    TPX = Screen.TwipsPerPixelX
    ListView1.ColumnHeaders.Add , , "Dateiname", 140 * TPX, 0
    ListView1.ColumnHeaders.Add , , "Größe", 70 * TPX, 1
    ListView1.ColumnHeaders.Add , , "Typ", 160 * TPX, 0
    ListView1.ColumnHeaders.Add , , "Geändert am", 120 * TPX, 0
    ListView1.ColumnHeaders.Add , , "Attribute", 60 * TPX, 1
    Drive1.Drive = "C:\"
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set ListView1.Icons = Nothing
  Set ListView1.SmallIcons = Nothing
  ImageList1.ListImages.Clear
  ImageList2.ListImages.Clear
End Sub

Private Sub ListView1_DblClick()
  Dim x&, aa$
  
    x = ListView1.SelectedItem.Index
    If x <> 0 Then
      If DirList(x - 1).Type = "Verzeichnis" Then
        aa = Dir1.Path
        If Right$(aa, 1) <> "\" And Right$(aa, 1) <> "/" Then
          aa = aa & "\"
        End If
        Dir1.Path = aa & DirList(x - 1).File
      End If
    End If
End Sub

Private Sub Option1_Click(Index As Integer)
  Select Case Index
    Case 0: ListView1.View = lvwReport
    Case 1: ListView1.View = lvwList
    Case 2: ListView1.View = lvwSmallIcon
    Case 3: ListView1.View = lvwIcon
  End Select
End Sub

Private Sub Dir1_Change()
  Call ViewFolder(Dir1.Path, "*.*")
End Sub

Private Sub Drive1_Change()
  Dir1.Path = Drive1.Drive
End Sub

Private Sub ViewFolder(Root$, Patt$)
  Dim Tmp As ListItem, x%, y&, Ext$
  
    MousePointer = vbHourglass
    ListView1.ListItems.Clear
    If Not GetFiles(Root, Patt) Then Exit Sub
    MousePointer = vbDefault
    DoEvents
      
    Set ListView1.Icons = ImageList2
    Set ListView1.SmallIcons = ImageList1
       
    For x = 0 To UBound(DirList) - 1
      Ext = DirList(x).Ext
      If Ext <> "" Then
        Set Tmp = ListView1.ListItems.Add(, , DirList(x).File, _
                                          Ext, Ext)
                                          
        If Ext <> "Folder" Then
          y = DirList(x).FileLen \ 1024 + 1
          Tmp.SubItems(1) = y & " KB"
        End If
      End If

      Tmp.SubItems(2) = DirList(x).Type
      Tmp.SubItems(3) = CalcFTime(DirList(x).LastWrite)
      Tmp.SubItems(4) = GetAttributes(DirList(x).Attributes)
      If x Mod 1000 = 0 Then ListView1.Refresh
    Next x
End Sub

Private Function GetFiles(Root$, Patt$) As Boolean
  Dim File$, hFile&, FD As WIN32_FIND_DATA
  Dim Ext$, Lcnt%, x&, y&, Extr%, Folder As Boolean
  Dim Descrp$, DescrpCol$
  Const Extra = "|zico=Symbol|zexe=Anwendung|" & _
                "zlnk=Verknüpfung|zcur=Cursor|"

    If Right$(Root, 1) <> "\" And Right$(Root, 1) <> "/" Then
      Root = Root & "\"
    End If

    DescrpCol = "|Folder=Verzeichnis|"
    ReDim DirList(0)
    Set ListView1.Icons = Nothing
    Set ListView1.SmallIcons = Nothing
    ImageList1.ListImages.Clear
    ImageList2.ListImages.Clear
  
    hFile = FindFirstFile(Root & Patt, FD)
    If hFile = 0 Then Exit Function
    Do
       File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
       If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
         = FILE_ATTRIBUTE_DIRECTORY Then
         If (File <> ".") And (File <> "..") Then
           With DirList(UBound(DirList))
             .Attributes = FD.dwFileAttributes
             .FileLen = FD.nFileSizeLow
             .LastWrite = FD.ftLastWriteTime
             .Ext = "Folder"
             .File = File
             .Type = "Verzeichnis"
           End With
           ReDim Preserve DirList(0 To UBound(DirList) + 1)
           If Not Folder Then Folder = True
         End If
       Else
         Ext = "z" & LCase(GetExtension(File))
         
         x = InStr(1, DescrpCol, "|" & Ext & "=")
         y = InStr(1, Extra, "|" & Ext & "=")
         
         If x = 0 Or y <> 0 Then
           If y <> 0 Then
             y = y + Len(Ext) + 2
             x = InStr(y, Extra, "|")
             Descrp = Mid$(Extra, y, x - y)
             
             Ext = Ext + CStr(Extr)
             Extr = Extr + 1
           Else
             Descrp = GetFileType(Root & File)
             DescrpCol = DescrpCol & Ext & "=" & Descrp & "|"
           End If
           ImageList1.ListImages.Add , Ext, LoadIcon(Small, Root & File)
           ImageList2.ListImages.Add , Ext, LoadIcon(Large, Root & File)
           Lcnt = Lcnt + 1
         Else
           x = x + Len(Ext) + 2
           y = InStr(x, DescrpCol, "|")
           Descrp = Mid$(DescrpCol, x, y - x)
         End If
         
         With DirList(UBound(DirList))
           .Attributes = FD.dwFileAttributes
           .FileLen = FD.nFileSizeLow
           .LastWrite = FD.ftLastWriteTime
           .Ext = Ext
           .File = File
           .Type = Descrp
         End With
         ReDim Preserve DirList(0 To UBound(DirList) + 1)
       End If
    Loop While FindNextFile(hFile, FD)
    Call FindClose(hFile)
    
    If Folder Then
      ImageList1.ListImages.Add , "Folder", LoadIcon(Small, App.Path)
      ImageList2.ListImages.Add , "Folder", LoadIcon(Large, App.Path)
    End If
    
    If UBound(DirList) > 0 Then
      Call SortName
      GetFiles = True
    End If
End Function

Private Function GetExtension(ByVal FileName$) As String
  Dim aa$, BB$, x&
    For x = Len(FileName) To 1 Step -1
      If Mid$(FileName, x, 1) = "." Then Exit For
    Next x
    GetExtension = Mid$(FileName, x + 1)
End Function

Private Function LoadIcon(Size&, File$) As IPictureDisp
  Dim Result&
  Dim Unkown As IUnknown
  Dim Icon As IconType
  Dim CLSID As CLSIdType
  Dim ShellInfo As ShellFileInfoType

    Call SHGetFileInfo(File, 0, ShellInfo, Len(ShellInfo), Size)
 
    Icon.cbSize = Len(Icon)
    Icon.picType = vbPicTypeIcon
    Icon.hIcon = ShellInfo.hIcon
    CLSID.id(8) = &HC0
    CLSID.id(15) = &H46
    Result = OleCreatePictureIndirect(Icon, CLSID, 1, Unkown)
    Set LoadIcon = Unkown
End Function

Private Function GetFileType(File$) As String
  Dim Result&
  Dim ShellInfo As ShellFileInfoType
    
    Call SHGetFileInfo(File, 0, ShellInfo, Len(ShellInfo), _
                       SHGFI_TYPENAME)
                       
    Result = InStr(1, ShellInfo.szTypeName, Chr$(0)) - 1
    GetFileType = Left(ShellInfo.szTypeName, Result)
End Function

Private Function GetAttributes(Att&) As String
  Dim aa$
  
    If Att And FILE_ATTRIBUTE_TEMPORARY Then aa = "T"
    If Att And FILE_ATTRIBUTE_READONLY Then aa = aa & "R"
    If Att And FILE_ATTRIBUTE_HIDDEN Then aa = aa & "H"
    If Att And FILE_ATTRIBUTE_SYSTEM Then aa = aa & "S"
    If Att And FILE_ATTRIBUTE_NORMAL Then aa = aa & "N"
    If Att And FILE_ATTRIBUTE_COMPRESSED Then aa = aa & "C"
    If Att And FILE_ATTRIBUTE_ARCHIVE Then aa = aa & "A"
    GetAttributes = aa
End Function


Private Function CalcFTime(FTime As FILETIME) As String
  Dim Datum$, Zeit$, aa$, hh$, mm$, ss$, DT As Date
  Dim Da$, Mo$, Ye$
  Dim STime As SYSTEMTIME
  
    Call FileTimeToSystemTime(FTime, STime)
    With STime
      Da = .wDay
      If Len(Da) < 2 Then Da = "0" & Da
      
      Mo = .wMonth
      If Len(Mo) < 2 Then Mo = "0" & Mo
      
      Ye = CStr(.wYear)
      
      mm = Trim$(CStr(.wMinute))
      If Len(mm) < 2 Then mm = "0" & mm
      
      ss = Trim$(CStr(.wSecond))
      If Len(ss) < 2 Then ss = "0" & ss
      
      hh = Trim$(CStr(.wHour))
      If Len(.wHour) < 2 Then hh = "0" & hh

      CalcFTime = Da & "." & Mo & "." & Ye & " " _
                  & hh & ":" & mm & ":" & ss
    End With
End Function

Private Function SortName()
  Dim x%, Mem As DIRLISTTYPE, Max%
  
   For x = 0 To UBound(DirList) - 1
     If DirList(x).Type = "Verzeichnis" Then
       Mem = DirList(Max)
       DirList(Max) = DirList(x)
       DirList(x) = Mem
       Max = Max + 1
     End If
   Next x
   
   If Max <> 0 Then Call QuickSort(0, Max - 1)
   If Max < UBound(DirList) Then
     Call QuickSort(Max, UBound(DirList) - 1)
   End If
End Function

Private Sub QuickSort(ByVal LB&, ByVal UB&)
  Dim P1&, P2&, Ref$, TEMP As DIRLISTTYPE

    P1 = LB
    P2 = UB
    Ref = DirList((P1 + P2) / 2).File
    
    Do
      Do While (DirList(P1).File < Ref)
        P1 = P1 + 1
      Loop
 
      Do While (DirList(P2).File > Ref)
        P2 = P2 - 1
      Loop

      If P1 <= P2 Then
        TEMP = DirList(P1)
        DirList(P1) = DirList(P2)
        DirList(P2) = TEMP
            
        P1 = P1 + 1
        P2 = P2 - 1
      End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(LB, P2)
    If P1 < UB Then Call QuickSort(P1, UB)
End Sub


'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 8 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.