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
.AttachedTemplate = oTemplate
Set docVorlage = Documents.Open(oTemplate, Visible:=False)
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
MsgBox intVergeblich & " vergebliche Versuche!" & Chr(13) & intGeklappt & " erfolgreiche!" & _
Chr(13) & intBenutzte & " benutzte!"
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