Public Sub ZipFile(ZipArchive As String, Filelist As String)
 
   'Die Fileliste kann sowohl Ordner als auch
   'Files enthalten und ist durch ; getrennt
 
   Dim sZipFile As String, sFiles() As String, bSilent As Boolean, oFSO As _
     Object, f As Integer
 
   sZipFile = ZipArchive
   sFiles = Split(Filelist, ";")
 
   Dim oShell As Object
   Dim oFolder As Object
   Dim bResult As Boolean
 
   ' Fehlerbehandlung aktivieren
   'On Error GoTo ErrHandler
 
   ' Verweis auf Shell.Application erstellen
   Set oShell = CreateObject("Shell.Application")
   Set oFSO = CreateObject("Scripting.fileSystemObject")
 
   'wenn es die Datei schon gibt - löschen
   If oFSO.fileexists(sZipFile) = True Then oFSO.DeleteFile (sZipFile)
 
   'Datei erstellen
   oFSO.CreateTextFile(sZipFile, True).WriteLine "PK" & Chr(5) & Chr(6) & _
     String(18, 0)
 
   'Dateien hinzufügen
   Set oFolder = oShell.NameSpace((sZipFile))
   For f = 0 To UBound(sFiles)
      oFolder.CopyHere oShell.NameSpace((sFiles(f))).Items
   Next f
   Set oFolder = Nothing
 
zip_End:
  Set oShell = Nothing
  On Error GoTo 0
 
  Windows_Unzip = bResult
  Exit Sub
 
ErrHandler:
   Resume zip_End
End Sub

Public Sub unZipFile(ZipArchive As String, Verzeichnis As String)
 
 Dim sZipFile As String, sDestFolder As String, bSilent As Boolean
 
 
 sZipFile = ZipArchive
 sDestFolder = Verzeichnis
 bSilent = True
 
  Dim oShell As Object
  Dim oFolder As Object
  Dim bResult As Boolean
 
  ' Fehlerbehandlung aktivieren
  On Error GoTo ErrHandler
 
  ' Verweis auf Shell.Application erstellen
  Set oShell = CreateObject("Shell.Application")
 
    ' UnZip-Funktion aufrufen
    Set oFolder = oShell.NameSpace((sDestFolder))
    If Not oFolder Is Nothing Then
      oFolder.CopyHere oShell.NameSpace((sZipFile)).Items
      Set oFolder = Nothing
    End If
 
Unzip_End:
  Set oShell = Nothing
  On Error GoTo 0
 
  Windows_Unzip = bResult
  Exit Sub
 
ErrHandler:
  ' Fehler anzeigen?
  If Not bSilent Then
    MsgBox "Fehler beim Aufruf der Windows UnZip-Funktion!" & vbCrLf & _
      CStr(Err.Number) & " " & Err.Description, vbExclamation Or vbOKOnly
  End If
  Resume Unzip_End
 
End Sub

Joachim