Ein- Auszippen, Löschen und Auflisten ohne Zip-Programm
#1
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
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


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



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


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



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



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


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

_________
viele Grüße
Karl-Heinz


.xlsb   Zip-Datei-Analysen2023.xlsb (Größe: 64,91 KB / Downloads: 4)
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste