Sub email()
Dim data As String
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Set rngZiel = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
data = rngZiel.Text
Dim dataa() As String
dataa = Split(data)
Dim kostenstelle As String
Dim empf, empf2 As String
kostenstelle = dataa(2)
empf = dataa(0)
empf2 = dataa(1)
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Dim pfad As String
pfad = ActiveDocument.FullName
Dim name1a() As String
name1a = Split(pfad, ".docx")
pfad = name1a(0)
ActiveDocument.ExportAsFixedFormat pfad + ".pdf", 17
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.Recipients.Add empf
If Not empf2 Or Not empf2 Then
.Recipients.Add empf2
End If
.Subject = "f" & kostenstelle
.Body = "Sehr geehrte Damen und Herren,"
.ReadReceiptRequested = False
.Attachments.Add pfad + ".pdf"
.Display
End With
Set olApp = Nothing
ActiveDocument.Save
ActiveDocument.Close
End Sub