ZIP - mit 7Zip bestimmte Dateien eines Ordners mit Passwort packen...

OptionExplicit
' API Funktion um einen Ordner anzulegen
#If Win64 Then
PrivateDeclarePtrSafeFunctionMakeSureDirectoryPathExists_
Lib"imagehlp.dll"(ByValstrPathAsString)AsLong
#Else
PrivateDeclareFunctionMakeSureDirectoryPathExists_
Lib"imagehlp.dll"(ByValstrPathAsString)AsLong
#End If
' Konstante für die KONSOLENANWENDUNG 7Zip
' Keine Installation erforderlich
' Pfad ANPASSEN!!!!!!!!
ConststrZipAsString="C:\Temp\Zip\7za.exe"
'--------------------------------------------------------------------------
' Module    : Modul1
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.08.2013
' Purpose   : 7-Zip alle Dateien eines Ordners packen als 7z...
'--------------------------------------------------------------------------
PublicSubMain()
DimobjFileFolderAsObject
DimstrTMPFolderAsString
DimlngLastRowAsLong
DimstrPathQAsString
DimstrPathZAsString
DimstrArgAsString
DimobjFSOAsObject
OnErrorGoToFin
SetobjFSO=CreateObject("Scripting.FileSystemObject")
strTMPFolder=Environ$("TEMP")&_
Application.PathSeparator&"7zFiles"&_
Application.PathSeparator
' Temporärer Ordner im Tempordner anlegen
MakeSureDirectoryPathExistsstrTMPFolder
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier Tabelle1 = der CodeName der Tabelle
' Im VBA-Editor der Name VOR der Klammer - Tabelle1 (Tabelle1)
' im englischen Excel in der Regel Sheet1
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithTabelle1
' Letzte Zeile in Spalte B
lngLastRow=IIf(IsEmpty(.Cells(.Rows.Count,2)),_
.Cells(.Rows.Count,2).End(xlUp).Row,.Rows.Count)
' Pfad in dem die zu packenden Dateien sind
strPathQ=.Range("A1").Text
' Backslash anhängen, wenn nicht vorhanden
strPathQ=IIf(Right(strPathQ,1)<>"\",strPathQ&"\",strPathQ)
' Pfad in den die gepackte 7z-Datei kommt
strPathZ=.Range("C1").Text
' Backslash anhängen, wenn nicht vorhanden
strPathZ=IIf(Right(strPathZ,1)<>"\",strPathZ&"\",strPathZ)
' Schleife über alle Einträge in Spalte B
ForlngLastRow=1TolngLastRow
FileCopystrPathQ&.Cells(lngLastRow,2).Text,_
strTMPFolder&.Cells(lngLastRow,2).Text
NextlngLastRow
' Packt den Ordner strTMPFolder als 7z-Datei im Zielordner "strPathZ"
' Mit Passwort "passwort"
strArg=strZip&" a -ppasswort "&strPathZ&"Zip.7z "&strTMPFolder
ShellAndWaitstrArg
EndWith
' Und den temporären Ordner wieder löschen
SetobjFileFolder=objFSO.GetFolder(strTMPFolder)
objFileFolder.Delete
Fin:
' Objektvariablen zurücksetzen
SetobjFileFolder=Nothing
SetobjFSO=Nothing
' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
' und die Fehlerbeschreibung aus
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : ShellAndWait
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.08.2013
' Purpose   : ShellAndWait mit ausgeblendetem Dosfenster...
'--------------------------------------------------------------------------
PrivateSubShellAndWait(ByValstrPathNameAsString)
DimWshShellAsObject
OnErrorGoToFin
SetWshShell=CreateObject("WScript.Shell")
WshShell.RunstrPathName,0,True
Fin:
SetWshShell=Nothing
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub