Zip-Dateien - Inhaltsverzeichnisse auslesen, Dateien lesen incl. Zip-Inhalte

[volti]

Liebe Leserin, lieber Leser,

manchmal besteht der Wunsch, den Inhalt einer Zip-Datei zu erfahren, z.B. für eine Dateisuche.
Mit den bekannten Methoden zur Dateiermittlung werden nur die in den Ordnern der Festplatte befindlichen Dateien aufgelistet, die Dateien in den Zip-Archiven bleiben jedoch unberücksichtigt.

Mit diesem einfachen Code kannst Du die Dateinamen in einer Zip-Datei leicht auslesen:

Code:

Sub Zip_Expressliste()
' Inhalt aus Zip-Datei auslesen
  Dim vDatei As Variant, i As Variant
 
  vDatei = Application.GetOpenFilename("ZIP-Dateien (*.zip), *.zip")
  If vDatei = "" Then Exit Sub

  With CreateObject("shell.application").Namespace(vDatei)
      For i = 0 To .items.Count - 1
          Debug.Print .items.Item(i)
      Next i
  End With
End Sub

Allerdings werden hierbei keine Unterordner in der Zip-Datei ausgelesen, so dass dieser Code eher weniger brauchbar ist.

Dieser erweiterte Code berücksichtigt auch Unterordner und es wird sogar die Größe der Datei(en) aufgelistet. In vielen Fällen ist das wohl völlig ausreichend.

Code:

Dim sArr() As String

Sub StarteEinfacheZipAnalyse()
' Zip-Inhalt in Array laden
  Dim vZipDatei As Variant, iAnz As Integer, x As Long
 
  vZipDatei = Application.GetOpenFilename("ZIP-Dateien (*.zip), *.zip")
  If vZipDatei = "" Then Exit Sub
  
  ReDim Preserve sArr(2, 0)
  
  x = InStrRev(vZipDatei, "\")
  If x > 0 Then
     sArr(0, 0) = Left$(vZipDatei, x - 1)         ' Pfad
     sArr(1, 0) = Mid$(vZipDatei, x + 1)          ' Datei
  End If
  iAnz = 1
  
  With CreateObject("Shell.Application")
      SetsArray .Namespace(vZipDatei), iAnz
  End With

' Ausgabe der Daten auf Blatt
  With Zip
      .Select
      .Cells.ClearContents
      .Cells(1, 1).Resize(1, 3) = Split("Pfad Dateiname Größe")
      .Cells(2, 1).Resize(iAnz, 3).Value = Application.Transpose(sArr())
  End With
  MsgBox "Es konnten " & iAnz - 1 & " Datei(en) ermittelt werden!", vbInformation, "Zip_Inhalt"
  
End Sub

Sub SetsArray(oZipItems As Object, iAnz As Integer)
  Dim oItem As Object
  
  For Each oItem In oZipItems.items
    If oItem.Name Like "*" Then
       ReDim Preserve sArr(2, iAnz)
       sArr(0, iAnz) = oItem.Path
       sArr(1, iAnz) = oItem.Name
       sArr(2, iAnz) = oItem.Size
       iAnz = iAnz + 1
    End If
    If oItem.IsFolder Then SetsArray oItem.GetFolder, iAnz
  Next oItem
  
End Sub

Befinden sich jedoch in der Zip-Datei eingebettete Zip-Dateien, so werden diese zwar als Datei ausgewiesen, deren Inhalt bleibt jedoch wieder unberücksichtigt.

Für die vollständige Auslesung des Inhalts einer Zip-Datei sowie der Anzeige der Dateigröße, des Änderungsdatums, der Packrate und der komprimierten Größe möchte ich mal weiter unten eine funktionierende Lösung aufzeigen...
Die Beispiele befinden sich auch in der beigefügten Demodatei.


  Zip-Datei-Analysen_CEF.xlsb (Größe: 51,42 KB / Downloads: 2)

Hier ist auch ein Beispielcode zum Auflisten aller Dateien eines gewählten Ordners (ggf. mit Unterordner) einschließlich der Inhalte der vorgefundenen Zip-Archive enthalten.

So, und nun viel Spaß und Erfolg damit...

Code:

Const cHeadtext = "Umfangreiche Zipinhalt-Ermittlung"

Sub StarteUmfangreicheZipAnalyse()
  Dim sDatei As String
 
  sDatei = Application.GetOpenFilename("ZIP-Dateien (*.zip), *.zip")
  If sDatei <> "" And sDatei <> "Falsch" Then CheckeZipDatei sDatei
End Sub

Private Sub CheckeZipDatei(sDatei As String)
' Function untersucht eine Zipdatei und erstellt ein Inhaltsverzeichnis
  Dim sData As String, sArr() As String, sMsgtxt As String
  Dim iPointer As Long, lWert As Long, i As Long, x As Long, iAnz As Long
  Dim iDateiLang As Long, iIcon As Long
  Dim oFSO As Object
  
  If Dir$(sDatei) <> "" Then
     Open sDatei For Binary As #1

' Feststellen, ob der Inhalt einer gültigen Zipdatei entspricht; nicht nur die Extension muss stimmen
     If Input(4, #1) <> "PK" Then                                  ' PK & Chr(3) & Chr(4)
        sMsgtxt = "Die ausgewählte Datei '" & sDatei & "' ist keine gültige Zip-Datei!"
        GoTo MsgboxInfo
     End If

' Zip-Datei Gesamt
     With CreateObject("Scripting.FileSystemObject").getfile(sDatei)
         ReDim sArr(6, i)
         sArr(1, i) = sDatei
         sArr(4, i) = "'---------": sArr(5, i) = sArr(4, i)
         Call GetDateiParams(sArr, i, "\")
         sArr(2, i) = .datelastmodified
         sArr(3, i) = .Size
     End With
     i = i + 1

' Einlesen der einzelnen Dateiabschnitte bis zum Inhaltsverzeichnis
     iPointer = 1
     Do While Not EOF(1)
        Seek #1, iPointer + 18
        lWert = GetValue(Input(4, #1))                              ' Länge des komprimierten Datenbereichs
        Seek #1, iPointer + 26

' Den iPointer um 30 plus Dateitextlänge plus Offset weitersetzen (Offset für Dateilänge=0 gebraucht)
        iPointer = iPointer + 30 + GetValue(Input(2, #1)) + GetValue(Input(2, #1))
        Seek #1, iPointer
        If Input(2, #1) <> "PK" Then iPointer = iPointer + lWert    ' Bei eingebundener ZipDatei ist kein Datenbody vorhanden
        Seek #1, iPointer
        If Input(4, #1) = "PK
" Then Exit Do
     Loop

' Einlesen der restlichen Zipdateibytes (Inhaltsverzeichnis)
     Seek #1, iPointer
     Do While Not EOF(1)
        ReDim Preserve sArr(6, i)
    
        Select Case Input(4, #1)                                    ' vierstellige PK/UT-Kennung lesen
        Case "PK
"                                                  ' PK & Chr(1) & Chr(2)
            sData = Input(8, #1)                                    ' unbekannter Binärblock

' Uhrzeit und Datum
            lWert = GetValue(Input(2, #1))
            sArr(2, i) = (lWert And &HF800) / &H800 & ":" _
                       & (lWert And &H7E0) / &H20 & ":" & (lWert And &H1F) * 2
            lWert = GetValue(Input(2, #1))
            sArr(2, i) = Format$(CDate((lWert And &H1F) & "." _
                        & (lWert And &H1E0) / &H20 & "." _
                        & ((lWert And &HFE00) / &H200) + 1980 & " " & sArr(2, i)), _
                        "dd.mm.yyyy   hh:mm:ss")

' Binärblock CRC holen (Zyklische Redundanzprüfung), aber neu nicht mehr verwendet
            sData = Input(4, #1)
            
' Größen holen
            sArr(5, i) = GetValue(Input(4, #1))                     ' PackedSize
            sArr(3, i) = GetValue(Input(4, #1))                     ' OriginalSize
            If sArr(3, i) <> 0 Then
               sArr(4, i) = Format$(1 - (sArr(5, i) / sArr(3, i)), "###.##%") ' Prozent
            End If
            iDateiLang = GetValue(Input(2, #1))                     ' Dateilänge
            sData = Input(16, #1)                                   ' weiterer unbekannter Binärblock

' Dateinamen, optionalen Pfad und Erweiterung ermitteln
            sArr(1, i) = Input(iDateiLang, #1)
            Call GetDateiParams(sArr, i)
            i = i + 1: iAnz = iAnz + 1                              ' Nächste Datei
      
        Case "PK"                                                  ' PK & Chr(5) & Chr(6)
            sData = Input(16, #1)                                   ' Mindestbyteanzahl lesen
            Do
              sData = Input(1, #1)
            Loop Until EOF(1) Or sData = "P"
            If EOF(1) Then Exit Do
            Seek #1, Seek(1) - 1                                    ' Position wieder vor das "P" setzen
        
        Case "PK" & Chr$(0)                                         ' PK & Chr(5) & Chr(0)
            sData = Input(9, #1)
        
        Case Else
            Do
              sData = Input(1, #1)
            Loop Until EOF(1) Or sData = "P"
            If EOF(1) Then Exit Do
            Seek #1, Seek(1) - 1                                    ' Position wieder vor das "P" setzen
        End Select
     Loop
    
' Datenausgabe auf dem Excelblatt
     sMsgtxt = "Es konnte kein Inhalt ermittelt werden!"
     If i > 1 Then
        With Zip
           .Select
           .Cells.ClearContents
           .Cells(1, 1).Resize(1, 7) = Split("Pfad Dateiname geändert Originalgröße Prozent Gepackt Erw")
           .Cells(2, 1).Resize(i, 7).Value = Application.Transpose(sArr())
        End With
        sMsgtxt = "Es konnten " & iAnz & " Datei(en) ermittelt werden!": iIcon = 1
     End If
  Else
     sMsgtxt = "Die Datei '" & sDatei & "' wurde nicht gefunden!"
  End If

MsgboxInfo:
  Close #1
  MsgBox sMsgtxt, IIf(iIcon = 1, vbInformation, vbCritical), cHeadtext
End Sub

Private Sub GetDateiParams(sArr, ByVal i As Long, Optional sSep As String = "/")
' Funktion holt Pfad, Dateiname und Suffix der in sArr(1,i) übergebenen Datei
  Dim x As Long

  x = InStrRev(sArr(1, i), sSep)
  If x > 0 Then
     sArr(0, i) = Left$(sArr(1, i), x - 1)         ' Pfad
     sArr(1, i) = Mid$(sArr(1, i), x + 1)          ' Datei
  End If
  x = InStrRev(sArr(1, i), ".")
  sArr(6, i) = LCase$(Mid$(sArr(1, i), x + 1))     ' Suffix
End Sub

Private Function GetValue(S As String) As Long
' Funktion wandelt einen String in eine Zahl um
  Dim i As Integer
 
  For i = 1 To Len(S)
      GetValue = GetValue + Asc(Mid(S, i, 1)) * 256 ^ (i - 1)
  Next i
End Function

_________
viele Grüße
Karl-Heinz