Mail mit Anhang funktioniert nicht
10.06.2021 16:35:43
Dirk
Ich benötige bitte Eure Hilfe !
Ich bin bestimmt kein Profi , bastel aber für mein Leben gern mit VBA
Ich versuche eine Mail mit pdf Anhang zu erzeugen .Auf normalem Weg bekomme ich das auch hin .Doch die speziellen Umstände lassen mich so langsam verzweifeln .
Für die Erzeugung der pdf werden vorher noch Spalten ausgeblendet und Zellfarben verändert .(mit dem Recorder gebastelt)
Das ganze wird dann mit einem relativen Pfad gespeichert und hier kommt mein Problem : ich bekomme die Datei dann nicht mehr als Anhang in die Mail
(Entweder habe ich den falschen Weg zum "Anhängen" oder die Erzeugung ist zu langsam - glaube ich). Er bleibt hängen bei : Attachments.Add strPDF .
Kann mir jemand helfen und mir sagen was ich falsch mache ?
Hier mein bisheriger Code
Sub pdfmailen()
Dim strPDF As String
Dim OutlookApp As Object, strEmail As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set strEmail = OutlookApp.CreateItem(0)
'PDF erzeugen
Range("R33,R34,R36,R38").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Columns("L:P").Select
Selection.EntireColumn.Hidden = True
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\" & Environ$("USERNAME") & _
"\Desktop\" & Format(ActiveSheet.Range("Z2")) & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
strPDF = "C:\Users\" & Environ$("USERNAME") & "\Desktop\" & Format(ActiveSheet.Range("Z2")) & ".pdf"
With strEmail
.to = Worksheets("Ereignisse").Range("K4")
.Subject = Range("Z2")
.Body = "Hallo zusammen !" & vbCrLf & vbCrLf & "Hier die aktuelle Planung für den " & Range("Z3") _
& vbCrLf & vbCrLf _
& "Mit freundlichem Gruß" & vbCrLf & vbCrLf _
Attachments.Add strPDF
.ReadReceiptRequested = False
.GetInspector.Display
End With
Columns("L:P").Select
Selection.EntireColumn.Hidden = False
Range("R33,R34,R36,R38").Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Set OutlookApp = Nothing
Set strEmail = Nothing
Range("Q1").Activate
End Sub