Const MyPath As String = "O:\PD\PD-xxxxxxxxxxxxxxxxxxxxxx" 'Hier den Pfad anpassen, unter dem du die PDFs _
speichern willst!
Sub SendPDFTD()
Dim MailTo As String
Dim MailCC As String
Dim MailSubject As String
Dim MailText As String
'Email Adresse aus f14 auslesen
MailTo = ActiveSheet.Range("F4").Value
'CC-Adressen: keine. Hier kannst du weitere eintragen, direkt oder als Zellreferenz
MailCC = "xx@xx.de"
'Betreff: Workbook-Name und Datum
MailSubject = ActiveWorkbook.Name & " " & Format(Date, "DD.MMM.YYYY")
'Standardtext, im Maildisplay noch änderbar
MailText = "Hallo TD, hier ist eine Reparturmeldung!" 'HTML! die (br) gegen HTML-Zeilenumbruch _
tauschen
Call SendSheetOutlook(MailSubject, MailTo, MailCC, MailText)
End Sub '***************************************************************************
'Makro to send Excel-Sheet directly with outlook
'April 2020,
'MODIFIED June 2013: Send pdf, not xlsx!
'***************************************************************************
Private Sub SendSheetOutlook(sSubject As String, sTo As String, sCC As String, sText As String) Dim olApp As Object Dim AWS As String Dim olOldBody As String 'define temporary Path and Filename AWS = MyPath & "\" & Format(Date, "YYYYMMDD") & "_" & Format(Time, "hhmmss") & "_" & _ WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "") 'export File as PDF ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=AWS, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False AWS = AWS & ".pdf" 'Make Email Set olApp = CreateObject("Outlook.Application") With olApp.CreateItem(0) .GetInspector.Display olOldBody = .htmlBody .To = sTo .cc = sCC .Subject = sSubject .htmlBody = sText & olOldBody .Attachments.Add AWS End With 'remove TEMP file '******************************** 'wenn du das PDF behalten möchtest, diese Zeile auskommentieren! 'sonst wird das temporäre PDF wieder gelöscht 'Kill AWS '******************************** End Sub