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