MS Word (2010) Kopf+Fußzeile bei mehreren Dokumenten ändern

[nrxpro]

Hallo Zusammen,

ich habe hier ca. 100 Word Dateien liegen, bei denen ich in der Kopf und in der Fußzeile einen falschen Namen durch den richtigen ersetzten muss.

Ich schätze mal, dass man das mit nem Macro machen könnte.

Hat da zufällig jemand einen Code am Start ?

[0x00_0x00]

Sub ChangeMultipleDocXFiles()
Dim intResult As Integer
Dim strPath As String
Dim arrFiles() As String
Dim i As Integer


'Selection Dialog wird geoeffnet
intResult = Application.FileDialog(msoFileDialogFolderPicker). Show


'Ueberpruefung ob der Dialog abgebrochen wurde
If intResult <> 0 Then
strPath = Application.FileDialog( _
msoFileDialogFolderPicker).SelectedItems(1)
arrFiles() = GetAllFilePaths(strPath)
For i = LBound(arrFiles) To UBound(arrFiles)
'Filter fuer .doc(x) Dateien sind nicht benoetigt, da ModifyFile Funktion nur Office-Dokumente bearbeitet
Call ModifyFile(arrFiles(i))
Next i
End If
End Sub






Private Sub ModifyFile(ByVal strPath As String)
Dim objDocument As Document
Set objDocument = Documents.Open(strPath)
objDocument.Activate


'Kopfzeile + Fußzeile einfuegen
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.TypeText Text:="Test-Kopfzeile"
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.TypeText Text:="Test-Fußzeile"
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument




objDocument.Close (True)
End Sub







Private Function GetAllFilePaths(ByVal strPath As String) _
As String()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim arrOutput() As String
ReDim arrOutput(1 To 1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strPath)
i = 1
'loops through each file in the directory and
'prints their names and path
For Each objFile In objFolder.Files
ReDim Preserve arrOutput(1 To i)
'print file path
arrOutput(i) = objFile.Path
i = i + 1
Next objFile
GetAllFilePaths = arrOutput
End Function


Stammt von http://software-solutions-online.com/word-vba-apply-macro-to-multiple-files/ wurde aber etwas umgeaendert und angepasst.