批量替换多个文档的页眉页脚

Question

现在我已经可以替换文件夹下的多个文档正文的关键字，但是无法替换存在于页眉页脚的关键字。

Answer 1

用的word 里面的 vba

Answer 2

Sub jieyong()
Application.ScreenUpdating = False  '关闭屏幕闪
 Dim arr() As String, i&, k&, x&, f, f1$, oDoc As Document
 Dim myFile$, myPath$, p%, myDoc As Object, myAPP As Object, txt$, Re_txt$
  brr = Array("机密", "航母", "航载机", "航空母舰", "战场", "作战", "海军", "航空兵", "着舰", "母舰", "本舰", "舰岸", "指控", "编队")
  crr = Array("%JM%", "%HM%", "%JZJ%", "%HKMJ%", "%ZC%", "%ZZ%", "%HJ%", "%HKB%", "%ZJ%", "%MJ%", "%BJ%", "%JA%", "%ZK%", "%BD%")
  Set myAPP = New Word.Application
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        ReDim Preserve arr(1)
        arr(1) = .SelectedItems(1) & "\"
    End With
    i = 1: k = 1
    Do While i < UBound(arr) + 1
        If arr(i) = "" Then Exit Do
        f = Dir(arr(i), vbDirectory) '第二个参数表示文件属性，在这里指的是文件夹或目录
        Do While f <> ""
            If InStr(f, ".") = 0 And f <> "" Then
                k = k + 1
                ReDim Preserve arr(k)
                arr(k) = arr(i) & f & "\"
            End If
            f = Dir
        Loop
        i = i + 1
    Loop
    For x = 1 To UBound(arr)
        If arr(x) = "" Then Exit For
        f1 = Dir(arr(x) & "*.docx*")
        Do While f1 <> "" '文件不为空
            Set oDoc = Documents.Open(arr(x) & f1, Visible:=False)
        If oDoc.ProtectionType = wdNoProtection Then '是否受保护
            For p = 0 To 13
             With oDoc.Content.find
             .Text = brr(p)
             .Replacement.Text = crr(p)
              .Forward = True
              .Wrap = 2
             .Format = False
              .MatchCase = False
              .MatchWholeWord = False
              .MatchByte = True
              .MatchWildcards = False
              .MatchSoundsLike = False
              .MatchAllWordForms = False
              .Execute Replace:=2
              Application.DisplayAlerts = wdAlertsNone
             End With
            Next
        End If
            oDoc.Save
            oDoc.Close
            f1 = Dir
        Loop
    Next x: Erase arr
    myAPP.Quit
    Application.ScreenUpdating = True
    MsgBox ("全部替换完毕！")
End Sub