VBA - 更改文件夾中的所有Word頁腳 - 不兼容

Question

多年來，我一直使用下面的VBA代碼來更改文件夾（包括子文件夾）中所有Word文件的頁腳。

它工作得很好，但只適用於Word 2003版本！現在，我使用的是Word 2010中，如果我開始的代碼我得到的錯誤：

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 

我無法弄清楚這個問題，我希望有人有一個解決方案。

Answer 1

首先，您需要一個遞歸文件夾解析例程。這應該工作。

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 

然後使用這個程序，在這裏你處理相應的每個文件的主要子程序：

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