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

Frage: Bestimmte Dateien eines Ordners mit 7-zip (inklusive Passwort) packen. Die Dateien sind in Spalte B gelistet (mal mehr, mal weniger). Der Quellordner ist in A1 gelistet und der Zielordner für die gezippte Datei in C1. Wie geht das?

Certain files in a folder with 7-zip pack (including password). The files are listed in column B (sometimes more, sometimes less). The source folder is listed in A1 and the destination folder for the zipped file in C1. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
ZIP - mit 7Zip bestimmte Dateien eines Ordners mit Passwort packen...[ZIP 4 MB]

Link:
7Zip...
7Zip - Download...

Option Explicit
' API Funktion um einen Ordner anzulegen
#If Win64 Then
    Private Declare PtrSafe Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal strPath As String) As Long
#Else
    Private Declare Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal strPath As String) As Long
#End If
' Konstante für die KONSOLENANWENDUNG 7Zip
' Keine Installation erforderlich
' Pfad ANPASSEN!!!!!!!!
Const strZip As String = "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...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim objFileFolder As Object
    Dim strTMPFolder As String
    Dim lngLastRow As Long
    Dim strPathQ As String
    Dim strPathZ As String
    Dim strArg As String
    Dim objFSO As Object
    On Error GoTo Fin
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strTMPFolder = Environ$("TEMP") & _
        Application.PathSeparator & "7zFiles" & _
        Application.PathSeparator
    ' Temporärer Ordner im Tempordner anlegen
    MakeSureDirectoryPathExists strTMPFolder
    ' 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
    With Tabelle1
        ' 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
        For lngLastRow = 1 To lngLastRow
            FileCopy strPathQ & .Cells(lngLastRow, 2).Text, _
                strTMPFolder & .Cells(lngLastRow, 2).Text
        Next lngLastRow
        ' Packt den Ordner strTMPFolder als 7z-Datei im Zielordner "strPathZ"
        ' Mit Passwort "passwort"
        strArg = strZip & " a -ppasswort " & strPathZ & "Zip.7z " & strTMPFolder
        ShellAndWait strArg
    End With
    ' Und den temporären Ordner wieder löschen
    Set objFileFolder = objFSO.GetFolder(strTMPFolder)
    objFileFolder.Delete
Fin:
    ' Objektvariablen zurücksetzen
    Set objFileFolder = Nothing
    Set objFSO = Nothing
    ' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
    ' und die Fehlerbeschreibung aus
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : ShellAndWait
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.08.2013
' Purpose   : ShellAndWait mit ausgeblendetem Dosfenster...
'--------------------------------------------------------------------------
Private Sub ShellAndWait(ByVal strPathName As String)
    Dim WshShell As Object
    On Error GoTo Fin
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.Run strPathName, 0, True
Fin:
    Set WshShell = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...