Option Explicit 
 
Private Const mc_DocTemplate As String = "Makro_uebung1.dot" 
 
Private Const mc_AppMsgTitle As String = "Rechnung nach World übergeben" 
 
Private m_strTemplateFile As String 
 
Private m_objWDApp As Word.Application 
Private m_objWDDoc As Word.Document 
__________________________________________________________
 
Private Sub UserForm_Initialize() 
 
    Dim strPath As String 
    
    strPath = ThisWorkbook.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 World 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 
        .ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit 
    End With 
 
    m_objWDApp.Application.Activate 
    
    Else 
        MsgBox "Es konnte kein neues Dokument auf Basis" & _ 
            " der Dokumentenvorlage " & mc_DocTemplate & _ 
            " erstellt werden!", vbOKOnly + vbCritical, _ 
            mc_AppMsgTitle 
        End If 
        On Error GoTo 0 
    End If 
    
    
    If TypeName(m_objWDDoc) = "Document" Then 
        AddTextToBookmarks "tmEins", TextBox1.Text 
        AddTextToBookmarks "tmZwei", TextBox2.Text 
        AddTextToBookmarks "tmDrei", TextBox3.Text 
        AddTextToBookmarks "tmVier", TextBox4.Text 
        AddTextToBookmarks "tmFuenf", TextBox5.Text 
        AddTextToBookmarks "tmSechs", TextBox6.Text 
        AddTextToBookmarks "tmSieben", TextBox7.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 UserForm_QueryClose(Cancel As Integer, CloseMode 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.Quit 
    End If 
    
    Set m_objWDApp = Nothing 
    
    On Error GoTo 0 
    
End Sub