AW: Mit OutMail.Attachments.Add mehrere Dateien anhäng
19.06.2019 21:00:18
Rob
Hi Niclaus,
nachfolgend der Code. Bei Fragen - fragen!
Option Explicit
Private Sub NewZip(sPath)
'Leere ZipFile erstellen
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Sub ZipFile()
Dim FileNameZip, SourceFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
'Quell- und Zielpfad angeben
SourceFolder = Environ("userprofile") & "\Desktop\Test\" 'Hier Quell-Pfad der zu _
komprimierenden Dateien anpassen
DefPath = Environ("userprofile") & "\Desktop\" 'Hier Ziel-Pfad anpassen. Achtung! Quell- _
und Zielpfad dürfen nicht übereinstimmen!
'Dynamischen Namen für die Zip-Datei vergeben
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "ZipFiles " & strDate & ".zip" 'Name der Zip-Datei bei Bedarf _
anpassen
'Leere Zip-File erstellen
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
'Dateien aus SourceFolder in FileNameZip kopieren
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(SourceFolder).Items
'Warten bis Komprimierung beendet ist
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).Items.Count = _
oApp.Namespace(SourceFolder).Items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
End Sub
Gruß Rob