Hallo,

ich möchte aus einer Word-Vorlage.dot die darin enthaltenen Formatvorlagen auf bestehende Dokumente übertragen.

Es sollen dabei auch und insbesondere die Formatierungen und Vorlagen der Formatierungen für Nummerierungen und Aufzählungen übertragen werden. Folgender Code tut zwar was, aber nicht, was ich gerne hätte.

Blöderweise erhalte ich regelmäßig einen Fehler 4198 ("Befehl misslungen"), den ich Zeile 76ff. versuche abzufangen. 
Schlußendlich besagt mir die Messagebox Zeile 85 dann aber, dass KEINE Formatvorlage angewandt wurde. 

Kann mir jemand sagen, was falsch ist und wie zu ändern?

Public Sub FormatvorlagenZuweisen()
   
    Dim oTemplate As String
    Dim oDoc As Document
    Dim oDocPath As String
    Dim intDokumentenzaehler As Integer
    intDokumentenzaehler = 0
    Dim intDokumentenzaehlerBearbeitet As Integer
    intDokumentenzaehlerBearbeitet = 0
    
    Dim intAnzahlZuPruefenderDateien As Integer
    intAnzahlZuPruefenderDateien = 0
    
    Dim oStyle As Style
    Dim strStyle As String
    Dim DocTmp As Document
    Dim i As Long
    
    Dim stlVorlage As Style
    Dim intBenutzte As Integer
    Dim intVergeblich As Integer
    Dim intGeklappt As Integer
    Dim docVorlage As Document
    
    Set fso = CreateObject("Scripting.Filesystemobject")
    
    
    oTemplate = fm1.txtBxPfadVorlage.Text
    oDocPath = fm1.txtBxPfadDokumentenOrdner.Text


    Application.DisplayAlerts = wdAlertsNone
    
    fm1.cmdBtnStart.Caption = "Bearbeitung läuft"
    
    intAnzahlZuPruefenderDateien = fso.GetFolder(oDocPath).Files.Count
    
    For Each f In fso.GetFolder(oDocPath).Files
    
        intDokumentenzaehler = intDokumentenzaehler + 1
        
        fm1.cmdBtnStart.Caption = "Bearbeitung / Prüfung läuft" & vbCrLf & intDokumentenzaehler & "/" & intAnzahlZuPruefenderDateien
        
        If LCase(Right(f.Name, 3)) = "doc" Or LCase(Right(f.Name, 4)) = "docx" Or LCase(Right(f.Name, 4)) = "docm" Then
            Set oDoc = Application.Documents.Open(f.Path, Visible:=False)
            With oDoc
            
                .CopyStylesFromTemplate Template:=oTemplate
                
                '   http://www.office-archive.com/59-word/55712f65c723e7ee.htm
                
                .AttachedTemplate = oTemplate
                
                  
                  Set docVorlage = Documents.Open(oTemplate, Visible:=False)
                  
                    ' Copy all styles using the organizer
                  intBenutzte = 0
                  intVergeblich = 0
                  intGeklappt = 0
                  
                  On Error Resume Next
                  
                  For Each stlVorlage In docVorlage.Styles
                  
                    If stlVorlage.InUse = True Then
                        intBenutzte = intBenutzte + 1
                    End If
                  
                    Application.OrganizerCopy _
                        Source:=docVorlage.FullName, _
                        Destination:=oDoc.FullName, _
                        Name:=stlVorlage.NameLocal, _
                        Object:=wdOrganizerObjectStyles
                        
                        If Err.Number = 4198 Then
                            intVergeblich = intVergeblich + 1
                        Else
                            intGeklappt = intGeklappt + 1
                        End If
                            
                  Next stlVorlage
                  
                  'http://www.office-loesung.de/ftopic39646_0_0_asc.php
                  MsgBox intVergeblich & " vergebliche Versuche!" & Chr(13) & intGeklappt & " erfolgreiche!" & _
                        Chr(13) & intBenutzte & " benutzte!"
                  
                  ' Close the template and don't save any changes.
                  docVorlage.Close False
                                
                .Save
                .Close
            End With
            intDokumentenzaehlerBearbeitet = intDokumentenzaehlerBearbeitet + 1
            Set oDoc = Nothing
            
        End If
    Next
    Set fso = Nothing
    Application.DisplayAlerts = wdAlertsAll

    MsgBox "Bearbeitete Dokumente: " & intDokumentenzaehlerBearbeitet
    
    fm1.cmdBtnStart.Caption = "Übertragung Formatierung starten" 
    
End Sub