26.03.2024, 14:15
Liebe Leserin. lieber Leser,
manchmal möchte man ein oder mehrere Dateien oder ganze Ordner in eine ZIP-Datei einzippen.
Insbesondere für das Masseneinzippen von Dateien in ggf. sogar mehrere ZIP-Dateien (z.B. für das Berichtswesen) nach Vorgaben (z.B. eine Excelliste) wäre eine automatische Lösung sehr willkommen oder sogar unerlässlich.
Hierfür gibt es das eine oder andere Programm, z.B. der PKZip Commandliner.
Wer jedoch keine Fremdsoftware verwenden kann, will oder darf, dem bietet sich noch eine VBA-Möglichkeit über die Shell.Application
Nachfolgend möchte ich mal mögliche Methoden für das Einzippen, das Auszippen, das Auflisten und das Löschen von Dateien aufzeigen.
Das funktioniert ganz gut. Es darf jedoch eine unschöne Besonderheit hierbei nicht unerwähnt bleiben.
Die Aktionen laufen asynchron zum VBA-Code ab.
Das heißt, man weiß nicht, wann die Aktionen abgeschlossen sind.
Beim Ablaufen in einer Schleife könnten Fehlermeldungen in Form einer Dialogbox auftauchen, die erstens vom User weggeklickt werden müssen und zweitens das Einzippen der Datei dann verhindern.
Eine ausreichende Zeitvorgabe z.B. durch Sleep kann das Problem beheben, kostet dann aber wieder unnütze Zeit.
Einzippen
Falls die Zielzipdatei nicht vorhanden ist, wird zunächst automatisch eine leere ZIP-Datei angelegt. Diese enthält lediglich die PK-Kennung und ein paar Platzhalter.
Anschließend werden entweder der übergebende Ordner oder in einer Schleife die Dateien entsprechend dem übergebenden Muster eingezippt.
Das kann problemlos mit oder ohne Anzeige einer Fortschrittsanzeige ablaufen oder im Problemfall mit den o.a. schon angesprochenen Fehlermeldungen.
PS: Einzippen
einer Datei oder eines Ordners ist in der Regel immer problemlos.
Um Nachfragen der Ersetzung bei bereits vorhandenen Dateien zu vermeiden, kann optional die ZIP-Datei vorher gelöscht werden.
Die Beantwortung der Nachfrage kann man aber auch automatisieren.
Wer möchte kann diese Funktion dafür einsetzen:
Sollten Fehlermeldungen aufgetreten sein, können diese vom Programm auch automatisch geschlossen werden.
Sie könnten sonst im Hintergrund verschwinden und dauerhaft im Arbeitsspeicher dahindämmern.
Das Schließen übernimmt dieser Code:
Extrahieren
Mit dem nachfolgend gezeigten Code können die Dateien aus der gewählten ZIP-Datei in einen beliebigen Ordner ausgezippt werden.
Der Zielordner muss vorhanden sein.
Falls das nicht der Fall sein sollte, wird er über die API-Funktion
ZIP-Inhalt anzeigen
Den Inhalt einer ZIP-Datei kann man sich mit dem u.a. Code ausgeben lassen.
Hierbei ist zu beachten, dass dieses die einfachste Art der Ausgabe ist. Lies hierzu auch diesen Artikel.
Weitere umfangreichere Methoden findest Du auch in der beigefügten Datei.
Löschen
Zum Löschen einer Datei aus einer ZIP-Datei kann der nachfolgend gezeigte Code verwendet werden.
Nachteilig wirkt sich hier die Nachfragedialogbox aus, die der Nutzer beantworten muss bevor es weiter geht.
Das Problem wurde aber mit ein paar API-Funktionen automatisiert und damit gelöst.
Declares
Die verwendeten Funktionen aus der Windows-API müssen vor ihrem Einsatz noch deklariert werden. Diese Declares sind als erstes im Modul vor allen Funktionen zu platzieren.
Zip-Datei-Analysen2023.xlsb (Größe: 64,91 KB / Downloads: 3)
manchmal möchte man ein oder mehrere Dateien oder ganze Ordner in eine ZIP-Datei einzippen.
Insbesondere für das Masseneinzippen von Dateien in ggf. sogar mehrere ZIP-Dateien (z.B. für das Berichtswesen) nach Vorgaben (z.B. eine Excelliste) wäre eine automatische Lösung sehr willkommen oder sogar unerlässlich.
Hierfür gibt es das eine oder andere Programm, z.B. der PKZip Commandliner.
Wer jedoch keine Fremdsoftware verwenden kann, will oder darf, dem bietet sich noch eine VBA-Möglichkeit über die Shell.Application
Nachfolgend möchte ich mal mögliche Methoden für das Einzippen, das Auszippen, das Auflisten und das Löschen von Dateien aufzeigen.
Das funktioniert ganz gut. Es darf jedoch eine unschöne Besonderheit hierbei nicht unerwähnt bleiben.
Die Aktionen laufen asynchron zum VBA-Code ab.
Das heißt, man weiß nicht, wann die Aktionen abgeschlossen sind.
Beim Ablaufen in einer Schleife könnten Fehlermeldungen in Form einer Dialogbox auftauchen, die erstens vom User weggeklickt werden müssen und zweitens das Einzippen der Datei dann verhindern.
Eine ausreichende Zeitvorgabe z.B. durch Sleep kann das Problem beheben, kostet dann aber wieder unnütze Zeit.
Einzippen
Code:
Sub Zip_Zufügen(ByVal sZipDateiname As String, ByVal sZipPfad As String, Optional bNeu As Boolean)
' Fügt Datei(en) gemäß Zip-Muster (mit *) zu einer ZIP-Datei hinzu
Dim iFF As Integer, Chr0Data(18) As Byte, i As Integer
Dim oZiel As Object, oQuel As Object, oItem As Object, hWnd As LongPtr
Dim sPfad As String, sZIPMuster As String, sFail As String
' Zip-Muster bearbeiten
sPfad = Left(sZipPfad, InStrRev(sZipPfad, "\")) ' Quellpfad extrahieren
sZIPMuster = Mid(sZipPfad, Len(sPfad) + 1) ' ZIP-Muster extrahieren
' Vorhandene ZIP-Datei ggf. vorher löschen
If Dir$(sZipDateiname) <> "" And bNeu Then Kill sZipDateiname
' Zunächst eine leere ZIP-Datei anlegen, falls noch nicht vorhanden
If Dir$(sZipDateiname) = "" Then
iFF = FreeFile
Open sZipDateiname For Binary Access Write As #iFF ' Datei öffnen
Put #iFF, , "PK" & Chr$(5) & Chr$(6) ' ZIP-Kennung schreiben
Put #iFF, , Chr0Data ' Grunddaten schreiben
Close #iFF ' Datei schließen
End If
' Zu zippende Datei(en) ermitteln
miDlgAnz = 0
With CreateObject("Shell.Application")
Set oZiel = .Namespace((sZipDateiname)) ' Zielobjekt setzen
If Right$(sZipPfad, 1) = "\" Then ' Ordner einzippen
oZiel.CopyHere .Namespace((sZipPfad))
Else ' Datei einzippen
With .Namespace((sPfad)) ' Quellobjekt setzen
For Each oItem In .Items
If oItem.Name Like sZIPMuster Then ' Wenn Item passt
mhTimer = SetTimer(0&, 0&, 10, AddressOf ZipErsetzProc)
oZiel.CopyHere oItem ' Jetzt Datei hinzufügen
Sleep 100: DoEvents
End If
Next oItem
End With
End If
End With
Sleep 500
Call EnumWindows(AddressOf DlgZuProc, 0) ' Alle evtl. Fehlermeldungen schließen
End Sub
Sub Test_Ordner_einzippen()
Zip "D:\MyZip.zip", "D:\Ziptest\"
End Sub
' Fügt Datei(en) gemäß Zip-Muster (mit *) zu einer ZIP-Datei hinzu
Dim iFF As Integer, Chr0Data(18) As Byte, i As Integer
Dim oZiel As Object, oQuel As Object, oItem As Object, hWnd As LongPtr
Dim sPfad As String, sZIPMuster As String, sFail As String
' Zip-Muster bearbeiten
sPfad = Left(sZipPfad, InStrRev(sZipPfad, "\")) ' Quellpfad extrahieren
sZIPMuster = Mid(sZipPfad, Len(sPfad) + 1) ' ZIP-Muster extrahieren
' Vorhandene ZIP-Datei ggf. vorher löschen
If Dir$(sZipDateiname) <> "" And bNeu Then Kill sZipDateiname
' Zunächst eine leere ZIP-Datei anlegen, falls noch nicht vorhanden
If Dir$(sZipDateiname) = "" Then
iFF = FreeFile
Open sZipDateiname For Binary Access Write As #iFF ' Datei öffnen
Put #iFF, , "PK" & Chr$(5) & Chr$(6) ' ZIP-Kennung schreiben
Put #iFF, , Chr0Data ' Grunddaten schreiben
Close #iFF ' Datei schließen
End If
' Zu zippende Datei(en) ermitteln
miDlgAnz = 0
With CreateObject("Shell.Application")
Set oZiel = .Namespace((sZipDateiname)) ' Zielobjekt setzen
If Right$(sZipPfad, 1) = "\" Then ' Ordner einzippen
oZiel.CopyHere .Namespace((sZipPfad))
Else ' Datei einzippen
With .Namespace((sPfad)) ' Quellobjekt setzen
For Each oItem In .Items
If oItem.Name Like sZIPMuster Then ' Wenn Item passt
mhTimer = SetTimer(0&, 0&, 10, AddressOf ZipErsetzProc)
oZiel.CopyHere oItem ' Jetzt Datei hinzufügen
Sleep 100: DoEvents
End If
Next oItem
End With
End If
End With
Sleep 500
Call EnumWindows(AddressOf DlgZuProc, 0) ' Alle evtl. Fehlermeldungen schließen
End Sub
Sub Test_Ordner_einzippen()
Zip "D:\MyZip.zip", "D:\Ziptest\"
End Sub
Falls die Zielzipdatei nicht vorhanden ist, wird zunächst automatisch eine leere ZIP-Datei angelegt. Diese enthält lediglich die PK-Kennung und ein paar Platzhalter.
Anschließend werden entweder der übergebende Ordner oder in einer Schleife die Dateien entsprechend dem übergebenden Muster eingezippt.
Das kann problemlos mit oder ohne Anzeige einer Fortschrittsanzeige ablaufen oder im Problemfall mit den o.a. schon angesprochenen Fehlermeldungen.
PS: Einzippen
einer Datei oder eines Ordners ist in der Regel immer problemlos.
Um Nachfragen der Ersetzung bei bereits vorhandenen Dateien zu vermeiden, kann optional die ZIP-Datei vorher gelöscht werden.
Die Beantwortung der Nachfrage kann man aber auch automatisieren.
Wer möchte kann diese Funktion dafür einsetzen:
Code:
Private Sub ZipErsetzProc()
' Führt einen Mausklick in der "Datei Kopieren"-Dlgbox durch
Dim PT As POINTAPI, R As RECT
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
mhDlg = FindWindowA("#32770", "Datei kopieren") ' Handle der Ersetzen-Dlgbox
If mhDlg <> 0 Then
GetWindowRect mhDlg, R ' Dlg-Position holen
SetCursorPos R.Left + 200, R.Top + 250 ' Cursor positionieren
mouse_event &H6, 0, 0, 0, 0 ' Mausklick Down und Up
End If
End Sub
' Führt einen Mausklick in der "Datei Kopieren"-Dlgbox durch
Dim PT As POINTAPI, R As RECT
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
mhDlg = FindWindowA("#32770", "Datei kopieren") ' Handle der Ersetzen-Dlgbox
If mhDlg <> 0 Then
GetWindowRect mhDlg, R ' Dlg-Position holen
SetCursorPos R.Left + 200, R.Top + 250 ' Cursor positionieren
mouse_event &H6, 0, 0, 0, 0 ' Mausklick Down und Up
End If
End Sub
Sollten Fehlermeldungen aufgetreten sein, können diese vom Programm auch automatisch geschlossen werden.
Sie könnten sonst im Hintergrund verschwinden und dauerhaft im Arbeitsspeicher dahindämmern.
Das Schließen übernimmt dieser Code:
Code:
Private Function DlgZuProc(ByVal hWnd As LongPtr, lParam As LongPtr) As Long
' Schließt alle ZIP-Fehlermeldungs-DlgBoxen beim Durchscannen aller Fenster
Dim sText As String * 64
GetWindowTextA hWnd, sText, 64 ' Fenstertext holen
If sText Like "ZIP-komprimierte Ordner - Fehler*" Then _
PostMessageA hWnd, &H10, 0&, 0& ' &H10=WM_CLOSE
DlgZuProc = 1 ' Nächstes Fenster
End Function
' Schließt alle ZIP-Fehlermeldungs-DlgBoxen beim Durchscannen aller Fenster
Dim sText As String * 64
GetWindowTextA hWnd, sText, 64 ' Fenstertext holen
If sText Like "ZIP-komprimierte Ordner - Fehler*" Then _
PostMessageA hWnd, &H10, 0&, 0& ' &H10=WM_CLOSE
DlgZuProc = 1 ' Nächstes Fenster
End Function
Extrahieren
Mit dem nachfolgend gezeigten Code können die Dateien aus der gewählten ZIP-Datei in einen beliebigen Ordner ausgezippt werden.
Der Zielordner muss vorhanden sein.
Falls das nicht der Fall sein sollte, wird er über die API-Funktion
Code:
Sub Zip_Extract(ByVal sZipDatei As String, ByVal sZielPfad As String)
' Alle Dateien aus einer sZipDatei nach sZielPfad extrahieren
If Dir$(sZipDatei) <> "" Then ' Ist Zip-Datei vorhanden?
SHCreateDirectoryExW 0&, StrPtr(sZielPfad), 0& ' Ggf. Zielordner erstellen
With CreateObject("Shell.Application")
.Namespace((sZielPfad)).CopyHere .Namespace((sZipDatei)).Items
End With
End If
End Sub
' Alle Dateien aus einer sZipDatei nach sZielPfad extrahieren
If Dir$(sZipDatei) <> "" Then ' Ist Zip-Datei vorhanden?
SHCreateDirectoryExW 0&, StrPtr(sZielPfad), 0& ' Ggf. Zielordner erstellen
With CreateObject("Shell.Application")
.Namespace((sZielPfad)).CopyHere .Namespace((sZipDatei)).Items
End With
End If
End Sub
ZIP-Inhalt anzeigen
Den Inhalt einer ZIP-Datei kann man sich mit dem u.a. Code ausgeben lassen.
Hierbei ist zu beachten, dass dieses die einfachste Art der Ausgabe ist. Lies hierzu auch diesen Artikel.
Weitere umfangreichere Methoden findest Du auch in der beigefügten Datei.
Code:
Sub Zip_Liste()
' Inhalt aus einer Zip-Datei auslesen
Dim vZipDatei As Variant, oItem As Object
vZipDatei = Application.GetOpenFilename("ZIP-Dateien (*.zip), *.zip")
If vZipDatei = "" Then Exit Sub
With CreateObject("Shell.Application").Namespace(vZipDatei)
For Each oItem In .Items
Debug.Print oItem.Name
Next oItem
End With
End Sub
' Inhalt aus einer Zip-Datei auslesen
Dim vZipDatei As Variant, oItem As Object
vZipDatei = Application.GetOpenFilename("ZIP-Dateien (*.zip), *.zip")
If vZipDatei = "" Then Exit Sub
With CreateObject("Shell.Application").Namespace(vZipDatei)
For Each oItem In .Items
Debug.Print oItem.Name
Next oItem
End With
End Sub
Löschen
Zum Löschen einer Datei aus einer ZIP-Datei kann der nachfolgend gezeigte Code verwendet werden.
Nachteilig wirkt sich hier die Nachfragedialogbox aus, die der Nutzer beantworten muss bevor es weiter geht.
Das Problem wurde aber mit ein paar API-Funktionen automatisiert und damit gelöst.
Code:
Sub Zip_Loeschen(ByVal sZipDatei As String, ByVal sZIPMuster As String)
' Datei(en)(sZIPMuster) aus einer sZipDatei entfernen
' Die Dialogbox-Abfrage wird automatisch in der ZipDeleteProc beantwortet
Dim oItem As Object
With CreateObject("Shell.Application").Namespace((sZipDatei)) ' Quellobjekt referenzieren
For Each oItem In .Items
If oItem.Name Like sZIPMuster Then ' Wenn Item passt...
mhTimer = SetTimer(0&, 0&, 100, AddressOf ZipDeleteProc)
oItem.InvokeVerb "Delete" ' Jetzt Datei löschen
Sleep 100: DoEvents ' 100ms warten
End If
Next oItem
End With
End Sub
Private Sub ZipDeleteProc()
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
mhDlg = FindWindowA("#32770", "Datei löschen") ' Handle der Abfrage-Dlgbox
If mhDlg <> 0 Then SendDlgItemMessageA mhDlg, 6, &HF5, 0&, 0& ' &HF5=BM_CLICK 6=ja, 2=nein
End Sub
' Datei(en)(sZIPMuster) aus einer sZipDatei entfernen
' Die Dialogbox-Abfrage wird automatisch in der ZipDeleteProc beantwortet
Dim oItem As Object
With CreateObject("Shell.Application").Namespace((sZipDatei)) ' Quellobjekt referenzieren
For Each oItem In .Items
If oItem.Name Like sZIPMuster Then ' Wenn Item passt...
mhTimer = SetTimer(0&, 0&, 100, AddressOf ZipDeleteProc)
oItem.InvokeVerb "Delete" ' Jetzt Datei löschen
Sleep 100: DoEvents ' 100ms warten
End If
Next oItem
End With
End Sub
Private Sub ZipDeleteProc()
KillTimer 0&, mhTimer: mhTimer = 0 ' Timer löschen
mhDlg = FindWindowA("#32770", "Datei löschen") ' Handle der Abfrage-Dlgbox
If mhDlg <> 0 Then SendDlgItemMessageA mhDlg, 6, &HF5, 0&, 0& ' &HF5=BM_CLICK 6=ja, 2=nein
End Sub
Declares
Die verwendeten Funktionen aus der Windows-API müssen vor ihrem Einsatz noch deklariert werden. Diese Declares sind als erstes im Modul vor allen Funktionen zu platzieren.
Code:
Option Explicit
Private Declare PtrSafe Function SetCursorPos Lib "User32" ( _
ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Sub mouse_event Lib "User32" (ByVal dwflags As Long, _
ByVal dx As Long, ByVal dy As Long, _
ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare PtrSafe Function GetWindowRect Lib "User32" ( _
ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare PtrSafe Function EnumWindows Lib "User32" ( _
ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "User32" () As LongPtr
Private Declare PtrSafe Function GetWindowTextA Lib "User32" ( _
ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function SHCreateDirectoryExW Lib "Shell32.dll" ( _
ByVal hWnd As LongPtr, ByVal pszPath As LongPtr, ByVal psa As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "User32" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendDlgItemMessageA Lib "User32" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function SetTimer Lib "User32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "User32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function PostMessageA Lib "User32" ( _
ByVal hWnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Dim mhTimer As LongPtr, mhDlg As LongPtr, miDlgAnz As Long
Dim miBusy As Long
Private Declare PtrSafe Function SetCursorPos Lib "User32" ( _
ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Sub mouse_event Lib "User32" (ByVal dwflags As Long, _
ByVal dx As Long, ByVal dy As Long, _
ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare PtrSafe Function GetWindowRect Lib "User32" ( _
ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare PtrSafe Function EnumWindows Lib "User32" ( _
ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "User32" () As LongPtr
Private Declare PtrSafe Function GetWindowTextA Lib "User32" ( _
ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function SHCreateDirectoryExW Lib "Shell32.dll" ( _
ByVal hWnd As LongPtr, ByVal pszPath As LongPtr, ByVal psa As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "User32" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendDlgItemMessageA Lib "User32" ( _
ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function SetTimer Lib "User32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "User32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function PostMessageA Lib "User32" ( _
ByVal hWnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Dim mhTimer As LongPtr, mhDlg As LongPtr, miDlgAnz As Long
Dim miBusy As Long
_________
viele Grüße
Karl-Heinz
viele Grüße
Karl-Heinz
Zip-Datei-Analysen2023.xlsb (Größe: 64,91 KB / Downloads: 3)