Word Dokumentenvorlage aus Excel heraus öffnen

Private Sub Urkunden_drucken()
Sub Urkunden_drucken()
Dim objWord As Object
Dim objBlatt As Worksheet
Dim intI As Integer
Dim strTitel As String
Dim strLänge As String
Dim strTitelliste As String
Dim iRow As Integer
Dim iloop As Integer
Dim anzahl_der_teilnehmer As Integer
'Das Tabellenblatt "Tabelle1n" öffnen
Sheets("Tabelle1").Select
'Hier werden nun die belegten Zeilen gezählt und somit die Teilnehmerzahl ermittelt
anzahl_der_teilnehmer = WorksheetFunction.Count(Sheets("Tabelle1").Range("B4:B65000").Value)
On Error Resume Next
'Listenfelddialog frmAuswahl aufrufen
With frmAuswahl
'Fenstertiteltext festlegen
.Caption = "drucken"
'Eingabeaufforderungstext festlegen
.lblPrompt.Caption = "Wählen Sie aus:"
'Listenfeld konfigurieren
With .lstListbox
'Zwei Spalten anlegen
.ColumnCount = 3
'Spaltenbreiten festlegen
.ColumnWidths = "0;-1;-1"
iloop = 0
iRow = 4
For Each objBlatt In ActiveWorkbook.Worksheets
'Alle Spalten mit Namen durchlaufen
If objBlatt.Name = "Tabelle1" Then
Do
'... Blattnamen in unsichtbare erste Spalte schreiben
.AddItem objBlatt.Name
If Cells(iRow, 4) <> "X" Then
'Namen des Teilnehmers in erste Spalte schreiben
.List(.ListCount - 1, 1) = objBlatt.Cells(iRow, 1).Value
'Geschwommene Strecke des Teilnehmers in zweite Spalte schreiben
.List(.ListCount - 1, 2) = objBlatt.Cells(iRow, 2).Value
End If
iRow = iRow + 1
iloop = iloop + 1
Loop While iloop < anzahl_der_teilnehmer
End If
Next
'Wenn Listenfeld leer ist, dann...
If .ListCount = 0 Then
'... Makro beenden
End
'Ansonsten...
Else
'... erstes Listenelement markieren
.ListIndex = 0
End If
End With
'Userform anzeigen
.Show
'Wenn Anwender 'Abbrechen' gewählt hat, dann...
If .Tag = "Abbruch" Then
'... Makro beenden
End
End If
Set objBlatt = GetWorksheet(.lstListbox.Value)
End With
'Neue Instanz von Microsoft Word starten
Set objWord = CreateObject("Word.Application")
'Bei Misserfolg...
If objWord Is Nothing Then
'... Fehlermeldung ausgeben
MsgBox "Word kann nicht gestartet werden.", vbCritical, APP_NAME
'Bei Erfolg...
Else
With objWord
'Word sichtbar machen
.Visible = True
'Neues Dokument auf Grundlage von Urkunde.dot anlegen
.Documents.Add template:=.Options.DefaultFilePath(2) & "\test.dot"
'Bei Misserfolg...
If Err <> 0 Then
'... Fehlermeldung anzeigen
MsgBox "Bitte kopieren Sie die Dokumentvorlage Urkunde.dot in das folgende Verzeichnis: " & vbCr &
.Options.DefaultFilePath(2), vbCritical, APP_NAME
'Word schließen
.Quit
'Objektvariable freigeben
Set objWord = Nothing
'Makro beenden
End
End If
MsgBox objBlatt.Name
'Textmarken der Inlay-Tabelle durch Albuminfos ersetzen
Call WordTextmarkeFüllen(objWord, .ActiveDocument, "Vorname", objBlatt.Cells(1, 2) & " - " & objBlatt.Cells(2,
2))
Call WordTextmarkeFüllen(objWord, .ActiveDocument, "Nachname", objBlatt.Cells(1, 2) & " - " & objBlatt.Cells(2,
2))
Call WordTextmarkeFüllen(objWord, .ActiveDocument, "Strecke", objBlatt.Cells(1, 2) & " - " & objBlatt.Cells(2,
2))
End With
'Objektvariable für Word-Zugriff freigeben (Word bleibt geöffnet)
Set objWord = Nothing
End If
'Makro beenden und alle Userform-Dialogfeldinhalte zurücksetzen
''End
End Sub

Private Sub WordTextmarkeFüllen(objWord As Object, objWDDokument As Object, strTMName As String, strTMWert As String)
'Wenn Textmarke existiert, dann...
If objWDDokument.Bookmarks.Exists(strTMName) = True Then
'... Textmarke markieren
objWDDokument.Bookmarks(strTMName).Range.Select
'Mit Inhalt überschreiben
objWord.Selection.Text = strTMWert
'Textmarke neu anlegen über neuem Inhalt
objWDDokument.Bookmarks.Add Range:=objWord.Selection.Range, Name:=strTMName
'Markierung aufheben
objWord.Selection.Collapse 0
End If
End Sub

Private Function GetWorksheet(strName As String) As Worksheet
Dim objBlatt As Worksheet
'Alle Blätter der aktuelle Arbeitsmappe durchlaufen
For Each objBlatt In ActiveWorkbook.Worksheets
'Wenn Blatt mit angegebenem Namen gefunden, dann...
If objBlatt.Name = strName Then
'... Verweis auf Blatt zurückliefern
Set GetWorksheet = objBlatt
'Schleife verlassen
Exit For
End If
Next
End Function