Option Explicit
 
Private Const mc_DocTemplate As String = "Beispiel.dot"
Private Const mc_AppMsgTitle As String = _
                    "Text an Word-Textmarken übergeben"
 
Private m_strTemplateFile As String
 
Private m_objWDApp  As Word.Application
Private m_objWDDoc  As Word.Document
 
Private Sub Form_Load()
  Dim strPath As String
 
  strPath = App.Path
  If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
 
  m_strTemplateFile = strPath & mc_DocTemplate
End Sub
 
Private Sub cmdCreateNewDoc_Click()

  If TypeName(m_objWDApp) <> "Application" Then
    On Error Resume Next
    Set m_objWDApp = Nothing
 
    Set m_objWDApp = CreateObject("Word.Application")
    If Err.Number <> 0 Then
      MsgBox "Konnte keine Verbindung zu Word herstellen !", _
             vbOKOnly + vbCritical, mc_AppMsgTitle
    End If
    On Error GoTo 0
  End If
 
  If TypeName(m_objWDApp) = "Application" Then
    m_objWDApp.Application.Visible = True
 
    If TypeName(m_objWDDoc) <> "Document" Then
      On Error Resume Next
      Set m_objWDDoc = Nothing
 
      Set m_objWDDoc = m_objWDApp.Documents.Add( _
           Template:=m_strTemplateFile, NewTemplate:=False)
 
      If Err.Number = 0 Then
        With m_objWDDoc.ActiveWindow
          .View.Type = wdPageView
          .ActivePane.View.Zoom.PageFit = wdPageFitBestFit
        End With
 
        m_objWDApp.Application.Activate
 
      Else
        MsgBox "Es konnte kein neues Dokument auf " & _
               "der Basis Dokumentvorlage '" & _
               mc_DocTemplate & "' erstellt werden!", _
               vbOKOnly + vbCritical, mc_AppMsgTitle
      End If
      On Error GoTo 0
    End If
 
    If TypeName(m_objWDDoc) = "Document" Then
      AddTextToBookmarks "tmKopfzeile", Text1.Text
      AddTextToBookmarks "tmDoc", Text2.Text
      AddTextToBookmarks "tmFusszeile", Text3.Text
    End If
  End If
End Sub
 
Private Sub AddTextToBookmarks(ByVal strBMName As String, _
      ByVal strBMText As String)
 
  Dim objBMRange As Word.Range
 
  With m_objWDDoc
    If .Bookmarks.Exists(strBMName) Then
      Set objBMRange = .Bookmarks(strBMName).Range
      objBMRange.Text = strBMText
      .Bookmarks.Add Name:=strBMName, Range:=objBMRange
      Set objBMRange = Nothing
    End If
  End With
End Sub
 
Private Sub cmdQuit_Click()
  Unload Me
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, _
      UnloadMode As Integer)
 
  On Error Resume Next
 
  If TypeName(m_objWDDoc) = "Document" Then
    m_objWDDoc.Close SaveChanges:=wdDoNotSaveChanges
  End If
  Set m_objWDDoc = Nothing
 
  If TypeName(m_objWDApp) = "Application" Then
    m_objWDApp.Application.Quit
  End If
  Set m_objWDApp = Nothing
 
  On Error GoTo 0
End Sub