Word über Vba Excel als PDF speichern

  Private Sub cb_PAdd_Click()
Dim PathFile As String
Dim objWDApp As Object
Dim objWDDoc As Object
Dim Pfad As String
Dim Dateiname As String
Dim pdfName As String
PathFile = ThisWorkbook.path & Application.PathSeparator & _
"Vorlage_PreAdd.doc"
Set objWDApp = OffApp("Word", True)
If Not objWDApp Is Nothing Then
Set objWDDoc = objWDApp.Documents.Open(PathFile, True)
Dateiname = TextBox2 & "_" & TextBox3 & "_" & TextBox4
If Dir(ThisWorkbook.path & "\" & Dateiname, vbDirectory) = "" Then
MkDir ThisWorkbook.path & "\" & Dateiname
MsgBox "Es wurde ein Ordner für die ID: " & TextBox2 & " erstellt!"
Pfad = ActiveWorkbook.path & "\" & Dateiname & "\"
Else
Pfad = ActiveWorkbook.path & "\" & Dateiname & "\"
End If
Dim Geschlecht As String
With objWDDoc
objWDApp.Visible = False
If ListBox1.ListIndex > -1 Then
If TextBox5.Text = "m" Then
Geschlecht = "Mr"
Else
Geschlecht = "Mrs"
End If
.Bookmarks("Mr_Mrs").Range = Geschlecht
.Bookmarks("Fam_Name").Range = TextBox3.Value
.Bookmarks("Vorname").Range = TextBox4.Value
.Bookmarks("Staatsangehörigkeit").Range = TextBox8.Value
.Bookmarks("E_Mail").Range = TextBox9.Value
.Bookmarks("ID").Range = TextBox2.Value
.Bookmarks("ID_1").Range = TextBox2.Value
.Bookmarks("Fam_Name_1").Range = TextBox3.Value
.Bookmarks("Vorname_1").Range = TextBox4.Value
.Bookmarks("Geburtstag").Range = TextBox6.Value
.Bookmarks("Geburtsort").Range = TextBox7.Value
.Bookmarks("Passnummer").Range = TextBox24.Value
...

Private Sub CommandButton9_Click()
Dim openDia
Dim wrdApp
Dim wrdDoc
Dim Pfad As String, Ordnername As String
Ordnername = TextBox2 & "_" & TextBox3 & "_" & TextBox4
Pfad = ThisWorkbook.path & "\" & Ordnername & "\" & TextBox1.Text & ".pdf"
openDia = Application.GetOpenFilename("Word-Dokumente, *.docx", , "Bitte Datei auswählen")
If openDia = False Then Exit Sub
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Add(openDia)
wrdDoc.ExportAsFixedFormat Pfad, 17
wrdDoc.Save
wrdDoc.Close
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub