Word Makro um Serienbriefe in einzelnen PDFs speichern

Option Explicit

Sub Serienbrief()
' set variables  
Dim iBrief As Integer, sBrief As String
Dim AppShell As Object
Dim BrowseDir As Variant
Dim Path As String
On Error GoTo ErrorHandling ' erfasse irgendwelche Fehler  

' Pfad bestimmen  
Set AppShell = CreateObject("Shell.Application")  
Set BrowseDir = AppShell.BrowseForFolder(0, "Speicherort für Serienbriefe auswählen", 0, 16)  

If BrowseDir = "Desktop" Then  
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")  
Else
Path = BrowseDir.items().Item().Path
End If

If Path = "" Then GoTo ErrorHandling  

Path = Path & "Serienbrief-" & Format(Now, "dd.mm.yyyy-hh.mm.ss") & ""  
MkDir Path

On Error GoTo ErrorHandling

' Anwendung ausblenden für bessere Leistung  
MsgBox "Serienbriefe werden exportiert. Dieser Vorganag kann einige Minuten dauern - Microsoft Word wird während dieser Zeit ausgeblendet", vbOKOnly + vbInformation  
Application.Visible = False

' Erstellen Sie Serienbrief und exportieren Sie als PDF  
With ActiveDocument.MailMerge
.DataSource.ActiveRecord = 1
Do
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
sBrief = Path & .DataFields("Firma").Value & " - " & .DataFields("Ort").Value & ".pdf"  
End With
.Execute Pause:=False

If .DataSource.DataFields("Firma").Value & " - " & .DataSource.DataFields("Ort").Value > "" Then  
ActiveDocument.SaveAs FileName:=sBrief, FileFormat:=wdFormatPDF
End If
ActiveDocument.Close False

If .DataSource.ActiveRecord < .DataSource.RecordCount Then
.DataSource.ActiveRecord = wdNextRecord
Else
Exit Do
End If

If .DataSource.ActiveRecord Mod 5 = 0 Then
DoEvents
End If

Loop
End With

' error handling  
ErrorHandling:
Application.Visible = True

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