Option Explicit
Sub BearbeiteDateien()
Dim folderPath As String
Dim templatePathPortrait As String
Dim templatePathLandscape As String
Dim templateDocPortrait As Document
Dim templateDocLandscape As Document
Dim file As String
folderPath = "C:\Users\sbutz\Desktop\Test docx\"
templatePathPortrait = "C:\Users\sbutz\Desktop\Fußzeile Hochformat.docx"
templatePathLandscape = "C:\Users\sbutz\Desktop\Fußzeile Querformat.docx"
Set templateDocPortrait = Documents.Open(FileName:=templatePathPortrait, Visible:=False)
Set templateDocLandscape = Documents.Open(FileName:=templatePathLandscape, Visible:=False)
BearbeiteDateienInOrdnerRekursiv folderPath, templateDocPortrait, templateDocLandscape
templateDocPortrait.Close SaveChanges:=False
templateDocLandscape.Close SaveChanges:=False
Set templateDocPortrait = Nothing
Set templateDocLandscape = Nothing
MsgBox "Fertig!"
End Sub
Sub BearbeiteDateienInOrdnerRekursiv(folderPath As String, templateDocPortrait As Document, templateDocLandscape As Document)
Dim file As String
Dim subfolder As String
Dim subfolders As Variant
Dim folders As Variant
folders = GetSubdirectoriesArray(folderPath)
For Each subfolders In folders
file = Dir(subfolders & "\" & "*.doc*")
Do While file <> ""
BearbeiteWordDatei subfolders & "\" & file, templateDocPortrait, templateDocLandscape
file = Dir
Loop
Next subfolders
End Sub
Sub BearbeiteWordDatei(filePath As String, templateDocPortrait As Document, templateDocLandscape As Document)
Dim doc As Document
Dim orientation As String
Dim rngTmp As Range, lngTmp As Long
Dim template As Document
Dim headFoot As HeaderFooter
Application.ScreenUpdating = False
Set doc = Documents.Open(filePath)
orientation = doc.PageSetup.orientation
With doc.Sections(1).Footers(wdHeaderFooterPrimary)
Select Case doc.PageSetup.orientation
Case wdOrientPortrait
Set template = templateDocPortrait
Case wdOrientLandscape
Set template = templateDocLandscape
End Select
Set headFoot = template.Sections(1).Footers(wdHeaderFooterPrimary)
headFoot.Range.Copy
.Range.Paste
Do While .Range.StoryLength > headFoot.Range.StoryLength
Set rngTmp = .Range
rngTmp.Start = rngTmp.End - 1
lngTmp = rngTmp.StoryLength
rngTmp.Delete
If rngTmp.StoryLength = lngTmp Then
Exit Do
End If
Loop
End With
With doc.PageSetup
.FooterDistance = CentimetersToPoints(0.4)
End With
doc.Save
doc.Close SaveChanges:=False
Set doc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetSubdirectoriesArray(ByVal folderPath As String) As Variant
Dim subfolders() As String
Dim subfolder As Object
Dim subfolderPath As String
Dim i As Integer
If Right(folderPath, 1) = "\" Then
folderPath = Left(folderPath, Len(folderPath) - 1)
End If
If Dir(folderPath, vbDirectory) = "" Then
MsgBox "Der angegebene Pfad existiert nicht.", vbExclamation
Exit Function
End If
ReDim subfolders(0)
subfolders(0) = folderPath
i = 1
With CreateObject("Scripting.FileSystemObject").GetFolder(folderPath)
For Each subfolder In .subfolders
subfolderPath = subfolder.Path
Dim subfolderSubdirectories As Variant
subfolderSubdirectories = GetSubdirectoriesArray(subfolderPath)
If Not IsEmpty(subfolderSubdirectories) Then
Dim subfolderCount As Integer
subfolderCount = UBound(subfolderSubdirectories) - LBound(subfolderSubdirectories) + 1
ReDim Preserve subfolders(i - 1 + subfolderCount)
Dim j As Integer
For j = LBound(subfolderSubdirectories) To UBound(subfolderSubdirectories)
subfolders(i) = subfolderSubdirectories(j)
i = i + 1
Next j
End If
Next subfolder
End With
GetSubdirectoriesArray = subfolders
End Function