VBA - Change all Word Footer in folder - not more compatible - vba

Question

For years I have used the VBA code below to change the footer in all Word files in a folder (including subfolders).
It works pretty well, but only to the version Word 2003! Now I'm using Word 2010 and if I start the code I get the error:
Run-time error 5111. The command is not available on this platform
Private Sub Image16_Click()
Dim Suchpfad, oPath
Folder = BrowseForFolder("Sélectionnez le dossier où les fichiers doivent être traitées")
If Len(Folder) = 0 Then
MsgBox "Vous n'avez pas sélectionné un dossier!"
Exit Sub
Else
'ChangeFileOpenDirectory Folder
oPath = Folder
'MsgBox oPath
End If
'**** Fußzeilen löschen
Pfad = oPath
With Application.FileSearch
.LookIn = Pfad
.SearchSubFolders = True
.FileType = msoFileTypeWordDocuments
.Execute
For i = 1 To .FoundFiles.Count
strName = .FoundFiles(i)
WordBasic.DisableAutoMacros
Documents.Open FileName:=strName
Dim Abschnitt As Section
For Each Abschnitt In ActiveDocument.Sections
For j = 1 To 3
On Error Resume Next
Abschnitt.Footers(j).Range.Delete
Next j
Next
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
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.WholeStory
Selection.Font.Name = "Verdana"
Selection.Font.Size = 7
Selection.TypeText Text:="First Line of Footer"
Selection.TypeParagraph
Selection.Font.Size = 6
Selection.TypeText Text:="Second Line of Footer"
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
ActiveDocument.Save
ActiveDocument.Close
Next
End With
MsgBox "Operation done in " & Pfad & " !!!"
End Sub
I can't figure out this problem and I hope that somebody has a solution.

Answer 1

First you will need a recursive folder parsing routine. This should work.
Public Sub RecursiveFolderParse(Folder, dictFiles As Object, sExt As String)
Dim SubFolder As Variant
Dim File As Variant
For Each SubFolder In Folder.SubFolders
RecursiveFolderParse SubFolder, dictFiles, sExt
Next
For Each File In Folder.Files
If Right$(File.Name, Len(sExt)) = sExt Then
If Not dictFiles.Exists(File.Path) Then
dictFiles.Add File.Path, 1
End If
End If
Next
End Sub
Then to use this routine, here is your main subroutine where you process each file accordingly:
Public Sub ProcessAllFiles()
Dim sFolder As String
Dim dictFiles As Object
Dim FileSystem As Object
Dim vKeys As Variant
Dim sFilename As Variant
Dim sExt As String
' define your folder and the extension to look for
sFolder = "C:\Test"
sExt = "zip"
Set dictFiles = CreateObject("Scripting.Dictionary")
Set FileSystem = CreateObject("Scripting.FileSystemObject")
RecursiveFolderParse FileSystem.GetFolder(sFolder), dictFiles, sExt
vKeys = dictFiles.Keys
For Each sFilename In vKeys
' process file code goes here
MsgBox sFilename
Next
End Sub