Suchen/Abspeichern/Zippen von Dateien
02.01.2019 13:52:10
Dateien
anbei ein Beispiel-Code, wo Dateinamen ohne Endung= (.pdf)in Spalte A der
Datei Zeichnung.xlsx enthalten sind. Diese Namen sind durch entsprechende Dateien.pdf in Ordner/Unterordnern zu suchen bzw. in eine Zieldatei zu speichern/zippen. Da der Code nicht vollständig ist, wäre super, wenn mir jemand helfen könnte. Der Befehl unter Kommentar "Name der Zip-datei" und "Zippen" funktioniert nicht.
Vielen Dank.
VG- Jo
Sub ZippenvonDateien()
Dim C As Range, strDat As String, strZip As Variant
Dim strListe As String, FF As Integer, sh, strMsg As String
Set sh = CreateObject("WScript.Shell")
'Verzeichnisse / Parameter (Switches)
Const strQuelle As String = "C:\Benutzer\albers\Desktop\Datenquelle\Zeichnung.xlsx" 'Backslash _
nicht vergessen!
Const str7Zip As String = """c:\Programme\7-Zip\7zM.exe""" 'Anpassen!
Const strParam As String = " -r -mx=5 -mmt=on" 'Unterverzeichnisse, normale _
Kompression, Mehrkernproz.
'Name der Zip-Datei:
strZip = Application.GetSaveAsFilename("C:\Benutzer\albers\Desktop\Ziel\Test.zip", "*.zip,*. _
zip")
If strZip = False Then Exit Sub
strZip = Chr(34) & strZip & Chr(34)
'Datei-Liste temporär anlegen
strListe = Mid(strZip, 2, InStrRev(strZip, "\") - 1) & Format(Now, "yyyy-mm-dd_hh-mm-ss")
FF = FreeFile()
Open strListe For Output As #FF
'Schleife über alle selektierten Zellen:
For Each C In Selection
'Dateiname
strDat = strQuelle & C.Value
'Existiert die Datei
If Dir(strDat, vbDirectory) "" Then
'in Liste schreiben
Print #FF, strDat
Else
strMsg = strMsg & vbLf & strDat
End If
Next
Close #FF
'Zippen
'Debug.Print str7Zip & " a -tzip " & strZip & " @" & Chr(34) & strListe & Chr(34) & strParam
sh.Run str7Zip & " a -tzip " & strZip & " @" & Chr(34) & strListe & Chr(34) & strParam, , _
True
Set sh = Nothing
'Liste löschen
Kill strListe
'Wurden manche Dateien nicht gefunden?
If Len(strMsg) > 0 Then
MsgBox "Es konnten folgende Dateien nicht gefunden werden:" & vbLf & strMsg
End If
End Sub