Outlook Abbruch Makro n. starten
01.04.2021 20:36:51
Guesa
folgendes Makro nutze ich um alle PDF Dateien aus einem Ordner zu versenden, anschließend sollen die Dateien in einen anderen Ordner verschoben werden. Funktioniert auch soweit. Nur, jetzt habe ich festgestellt das, wenn ich Outlook abbreche werden die Dateien trotzdem verschoben. Wie müsste der Code erweitert werden das dies nicht passiert. Für Hilfe schon mal ein Danke
Gruß, Guesa
Sub allesenden()
Dim strFolder As String, strFilename As String
Dim oApp As Object
Set oApp = CreateObject("Outlook.Application")
strFolder = Worksheets("Senden").Cells(3, 1).Value
If Left$(strFolder, 1) "\" Then strFolder = strFolder & "\"
With oApp.CreateItem(0)
.Sensitivity = 3
.To = Worksheets("Senden").Range("D1")
.CC = Worksheets("Senden").Range("D2")
.Subject = Worksheets("Senden").Range("D3")
.Body = Worksheets("Senden").Range("D4") & vbCr & vbCr & _
Worksheets("Senden").Range("D5") & " " & Worksheets("Senden").Range("G5") & vbCr & _
vbCr & _
Worksheets("Senden").Range("D6") & vbCr & vbCr & _
Worksheets("Senden").Range("D7") & vbCr & _
Worksheets("Senden").Range("D8") & vbCr
strFilename = Dir$(strFolder & "*")
Do Until strFilename = vbNullString
Call .Attachments.Add(strFolder & strFilename)
strFilename = Dir$
Loop
.Display
End With
Set oApp = Nothing
Call Dateien_verschieben
End Sub
Sub Dateien_verschieben()
Dim Quelle$, Ziel$, FSO As Object
Quelle = Worksheets("Senden").Range("A4")
If Dir(Quelle) = "" Then
MsgBox "Es befinden sich keine Dateien im Ordner Senden"
Else
Ziel = Worksheets("Senden").Range("A5")
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile Quelle, Ziel
Set FSO = Nothing
End If
End Sub