Option Explicit
' --------------------------------------------------------- 
' Funktion: createZip 
' Eingestellt von: Andre Schau 
' Datum: 5. Julei 2012 
' Kommentar: Anlegen oder Erweitern eines Zip-Files 
'            mit windowseigenem Zip 
' Parameter: strFullName = Dateiname mit Pfad 
'            boKillZip = Loeschen oder Belassen eines 
'            eventuell vorhandenen Zip-Files 
' Rückgabe: 
'Hinweise:   Keine Fehlerbehandlung. Moegliche Fehler 
'            z.B. fehlende oder offenen Dateien, keine 
'            Schreibrechte, fehlendes Laufwerk 
' Aufruf: 
Sub test()
'Variablendeklarationen 
'Objekt 
Dim objShell As Object
'Long 
Dim errNumber As Long
'Zip-File anlegen, falls nicht vorhanden 
'oder optional loeschen und neu anlegen 
createZip ("d:\test\test.zip")
'Shell-Objekt setzen 
Set objShell = CreateObject("Shell.Application")
'Datei kopieren und in Zip einfuegen 
objShell.Namespace("D:\Test\Test1.zip").CopyHere _
                   "D:\Test\Test1.xls"
End Sub
' --------------------------------------------------------- 

Function createZip(strFullName As String, _
                   Optional boKillZip As Boolean = True)
'Zip-File anlegen, falls nicht vorhanden 
'oder optional loeschen und neu anlegen 
'Uebergebene Parameter strFullName = Dateiname mit Pfad 
'boKillFile = True fuer loeschen des Zip, False fuer anfuegen 
'Variablendeklarationen 
'Integer 
Dim iFF As Integer
'Wenn zip vorhanden 
If Len(Dir(strFullName)) > 0 Then
  'Wenn boKillZio True, dann Zip loeschen oder Funktion verlassen 
  If boKillZip Then Kill strFullName Else Exit Function
'Ende Wenn zip vorhanden 
End If
'freie Filenummer zuweisen 
iFF = FreeFile
'Datei oeffnen 
Open strFullName For Output As #iFF
'Zip-Header schreiben 
Print #iFF, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
'Datei schließen 
Close #iFF
End Function