Option Explicit
Sub PruefePfadBriefRechnung()
Dim pf As String
Dim ws As Worksheet
Dim fileToOpen As Variant
Set ws = Worksheets("Pfade")
pf = ws.Range("PfadBriefRechnung")
If pf = "" Or Dir(pf) = "" Then
fileToOpen = Application.GetOpenFilename("Word Dokumentvorlage (*.dotx), *.dotx")
If fileToOpen <> False Then
ws.Range("PfadBriefRechnung") = fileToOpen & ""
Else
Err.Raise vbObjectError + 1, , "Fehlende Pfadangabe zur Vorlage 'BriefRechnung.dotx'."
End If
End If
End Sub
Sub BriefRechnungOeffnen()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim ws As Worksheet
On Error GoTo fehler
PruefePfadBriefRechnung
Set wdApp = GetObject(, "Word.Application")
wdApp.Visible = True
Set ws = Worksheets("Pfade")
Set wdDoc = wdApp.Documents.Add(ws.Range("PfadBriefRechnung") & "")
wdDoc.Bookmarks("KundenNr").Range.InsertAfter ActiveCell
wdDoc.Bookmarks("Anrede").Range.InsertAfter ActiveCell
wdDoc.Bookmarks("Nachname").Range.InsertAfter ActiveCell
wdDoc.Bookmarks("Vorname").Range.InsertAfter ActiveCell
wdDoc.Bookmarks("Adresse").Range.InsertAfter ActiveCell
wdDoc.Bookmarks("PLZ").Range.InsertAfter ActiveCell
wdDoc.Bookmarks("Ort").Range.InsertAfter ActiveCell
wdDoc.Bookmarks("Geburtstdatum").Range.InsertAfter ActiveCell
wdDoc.Bookmarks("Telefon").Range.InsertAfter ActiveCell
exit_sub:
Exit Sub
fehler:
If Err.Number = 429 Then
Set wdApp = CreateObject("Word.Application")
Resume Next
Else
MsgBox "Fehler: " & Err.Description & " " & Err.Number
Resume exit_sub
End If
End Sub
<span style="color: rgb(0, 0, 0); font-family: Arial, Verdana, Geneva, sans-serif; font-size: 14px; line-height: 19.441944122314453px; background-color: rgb(249, 249, 249);">Liebe Grüsse und schon mal vielen Dank.</span>
<span style="color: rgb(0, 0, 0); font-family: Arial, Verdana, Geneva, sans-serif; font-size: 14px; line-height: 19.441944122314453px; background-color: rgb(249, 249, 249);">Hannes </span>