|
Guten Morgen,
ich hab in Word 2019 einen Serienbrief, der die Personaldaten aus einer Excelliste rausholt. Darin stehen Namen, Tage und auch die Mailadressen zu jeder Person. Im Serienbrief selbst sind die Felder eingefügt bis auf die Mailadressen.
Ich möchte zu jeder einzelnen Person separat eine PDF erstellt und gespeichert haben und diese PDF dann direkt an die Person versendet bekommen.
Den VBA Code für das Erstellen der einzelnen PDF habe ich bereits und auch den Code, wie man eine Mail per VBA erstellt, aber ich bekomme leider beide nicht unter einen Hut und habe jetzt schon so viel gelöscht und umgeschrieben, dass ich schon gar nicht mehr weiß was noch stimmt. Verweise auf Outlook 16 Library ist auch angehakt.
Kann mir da bitte jemand helfen?
Option Explicit
Private Const Path_PDF As String = "mein Pfad"
Sub Serienbrief_im_PDF_Format_speichern()
Dim S As String
Dim DD As Double
Dim SS As Single
Dim AppShell As Object
Dim BrowseDir As Variant
Dim Path As String
Dim MyMessage As Object, MyOutApp As Object
On Error GoTo ErrorHandling
Path = Path_PDF & "mein Ordner\"
DD = Timer / 86400
SS = Timer - Int(Timer)
Debug.Print Hour(DD) & ":" & Minute(DD) & ":" & Format(Second(DD) + SS, "00.00")
Application.Visible = False
With ActiveDocument.MailMerge
.DataSource.ActiveRecord = 1
Do
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
S = Path & .DataFields("Name").Value & "," & .DataFields("Vorname").Value & ".pdf"
End With
.Execute Pause:=False
If .DataSource.DataFields("Name").Value > "" Then
ActiveDocument.SaveAs FileName:=S, FileFormat:=wdFormatPDF
End If
ActiveDocument.Close False
If .DataSource.ActiveRecord < .DataSource.RecordCount Then
.DataSource.ActiveRecord = wdNextRecord
Else
Exit Do
End If
Loop
End With
' error handling
ErrorHandling:
Application.Visible = True
DD = Timer / 86400
SS = Timer - Int(Timer)
Debug.Print Hour(DD) & ":" & Minute(DD) & ":" & Format(Second(DD) + SS, "00.00")
If Err.Number = 76 Then
MsgBox "Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
ElseIf Err.Number = 5852 Then
MsgBox "Das Dokument ist kein Serienbrief"
ElseIf Err.Number = 4198 Then
MsgBox "Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
ElseIf Err.Number = 91 Then
MsgBox "Exportieren von Serienbriefen abgebrochen", vbOKOnly + vbExclamation
ElseIf Err.Number > 0 Then
MsgBox "Unbekannter Fehler: " & Err.Number & " - Bitte Makro erneut ausführen.", vbOKOnly + vbCritical
Else
MsgBox "Serienbriefe erfolgreich exportiert", vbOKOnly + vbInformation
End If
End Sub
‘Mail erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Outlook Nachricht erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.SentOnBehalfOfName = Absender definiert
.To = .DataFields("Email").Value
.Subject = "mein Text"
.HTMLBody = .DataFields("Mailanrede").Value & .DataFields("Anrede").Value & .DataFields("Titel").Value & .DataFields("Name").Value & "<html><body><br><br>Das beigefügte Empfangsbekenntnis bitte ich bis zum 31.01.2025 gezeichnet zurückzusenden.<br><br>Für Fragen stehe ich gern zur Verfügung.<br></body></html>" & .HTMLBody
.AddAttachment = S
.Display
Dankeschön
|