AW: Dateien incl. Inhalte der ZIP auflisten?
13.11.2020 09:24:10
volti
Hall Selma,
das Auslesen über die Shell.Application-Methode (s.Luschi) ist schnell, klein und praktisch.
Bin mir aber nicht sicher, ob z.B. auch Zipinhalte aus Zip in Zip geholt werden können, falsch das auch benötigt werden sollte.
Und sollten noch weitere Infos benötigt werden:
In meiner Bastelkiste habe ich noch etwas aus alten Zeiten, mit dem Du auch gezippte Inhalte, Unterordner, Zip-Rate usw. extrahieren kannst.
Ist halt deutlich mehr Code, weil die Inhalte zu Fuß geholt werden, aber es funktioniert.
Probiere bei Bedarf mal das Tool aus. Sollte es gefallen, helfe ich Dir gern beim Einbau in Dein Tool.
Ansonsten wünsche ich viel Erfolg mit der anderen Methode...
Code:
[Cc][+][-]
Option Explicit
Const cHeadtext = "
Vereinfachte Zipinhalt-Ermittlung"
Sub Starte()
CheckeZipDatei "
C:\Users\voltm\Desktop\CustomUIEditor.zip"
End Sub
Private Sub CheckeZipDatei(sFile As String)
'
Function untersucht eine Zipdatei und erstellt ein Inhaltsverzeichnis
Dim sData
As String, iPointer
As Long, lWert
As Long, i
As Integer, X
As Integer
Dim iFileLength
As Long, sArr()
As String, Teil()
As String
If Dir$(sFile) <> "
"
Then
Open sFile
For Binary As #1
'Feststellen, ob der Inhalt einer gültigen Zipdatei entspricht; nicht nur die Extension muss stimmen
If Input(
4, #1) <> ("
PK" &
Chr$(
3) &
Chr$(
4))
Then
MsgBox "
Die gewählte Datei '" & sFile & "
' ist keine gültige Zip-Datei!",
vbCritical, cHeadtext
Close #1:
Exit Sub
End If
Seek #1,
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" &
Chr$(
1) &
Chr$(
2)
Then Exit Do
Loop
'Einlesen der restlichen Zipdateibytes (Inhaltsverzeichnis)
Seek #1, iPointer
Do While Not EOF(
1)
ReDim Preserve sArr(
9, i)
sData =
Input(
4, #1)
'vierstellige PK/UT-Kennung lesen
Select Case sData
Case "
PK" &
Chr$(
1) &
Chr$(
2)
sData =
Input(
8, #1)
'unbekannter Binärblock
'Uhrzeit und Datum
lWert = GetValue(
Input(
2, #1))
sArr(
2, i) =
Right$("
00" & ((lWert
And &HF800) /
&H800),
2) & "
:" _
&
Right$("
00" & ((lWert
And &H7E0) /
&H20),
2)
'Sekunden & Right$("00" & ((lWert And &H1F) * 2), 2)
lWert = GetValue(
Input(
2, #1))
sArr(
2, i) =
Right$("
00" & ((lWert
And &H1F)),
2) & "
." _
&
Right$("
00" & ((lWert
And &H1E0) /
&H20),
2) & "
." _
&
Right$("
00" & ((lWert
And &HFE00) /
&H200) +
1980,
4) _
& "
" & sArr(
2, i)
'Binärblock CRC holen
sData =
Input(
4, #1)
For X =
Len(sData)
To 1 Step -1
If sArr(
6, i) <> "
"
Then sArr(
6, i) = sArr(
6, i) & "
."
sArr(
6, i) = sArr(
6, i) &
Right("
00" &
Hex(
Asc(
Mid(sData, X,
1))),
2)
Next
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) =
1 - (sArr(
5, i) / sArr(
3, i))
'Prozent
End If
iFileLength = GetValue(
Input(
2, #1))
'Dateilänge
sData =
Input(
16, #1)
'weiterer unbekannter Binärblock
'Dateinamen und optionalen Pfad ermitteln
sArr(
1, i) =
Input(iFileLength, #1)
X = InStrRev(sArr(
1, i), "
/")
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
Teil =
Split(sArr(
1, i), "
.")
If UBound(Teil) >
0 Then sArr(
7, i) = Teil(
UBound(Teil))
i = i +
1
Case "
PK" &
Chr$(
5) &
Chr$(
6)
sData =
Input(
16, #1)
'Mindestbyteanzahl lesen
Do
sData =
Input(
1, #1)
If EOF(
1)
Or sData = "
P"
Then Exit Do
Loop
If EOF(
1)
Then Exit Do
Seek #1,
Seek(
1) -
1 'iPointer wieder vor das "P" setzen
Case "
PK" &
Chr$(
5) &
Chr$(
0)
sData =
Input(
9, #1)
Case Else
Do
sData =
Input(
1, #1)
If EOF(
1)
Or sData = "
P"
Then Exit Do
Loop
If EOF(
1)
Then Exit Do
Seek #1,
Seek(
1) -
1 'iPointer wieder vor das "P" setzen
End Select
Loop
If i =
0 Then
MsgBox "
Es konnte kein Inhalt ermittelt werden!",
vbCritical, cHeadtext
Else
With ActiveSheet
'Zip
.Select
.Cells.ClearContents
.Cells(
1,
1).Resize(1,
8) =
Array("
Pfad", "
Dateiname", "
geändert", "
Original", "
Prozent", "
Gepackt", "
CRC", "
Erw")
.Cells(
2,
1).Resize(i,
8).value = Application.Transpose(sArr())
End With
End If
Close #1
MsgBox "
Es konnten " &
CStr(i) & "
Datei(en) ermittelt werden!",
vbInformation, cHeadtext
Else
MsgBox "
Die Datei '" & sFile & "
' wurde nicht gefunden!",
vbCritical, cHeadtext
End If
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
End Function
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz