VB-Word添加页眉页脚

Word文档自定义宏添加页眉页脚标识：

'给指定目录下Word文件添加文档标识

Sub WordFlag()
    Dim FolderPicker As Object
    Dim FilePath As String
    
    Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FolderPicker
        If .Show = -1 Then
                FilePath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    Call getAllFile(FilePath)
    MsgBox ("文档标识添加已完成！")
End Sub

Sub getAllFile(sFolderPath As String)
'Columns(1).Delete
On Error Resume Next
Dim f As String
Dim file() As String
Dim i, k, x
x = 1
i = 1
k = 1
  
ReDim file(1 To i)
file(1) = sFolderPath & "\"
  
'-- 获得所有子目录
Do Until i > k
    f = Dir(file(i), vbDirectory)
        Do Until f = ""
            If InStr(f, ".") = 0 Then
                k = k + 1
                ReDim Preserve file(1 To k)
                file(k) = file(i) & f & "\"
            End If
            f = Dir
        Loop
    i = i + 1
Loop
  
'-- 获得所有目录下的所有文件
For i = 1 To k
    f = Dir(file(i) & "*.doc*")    '通配符*.*表示所有文件，*.doc* Word文件
    Do Until f = ""
       'Range("a" & x) = f
       'Range("a" & x).Hyperlinks.Add Anchor:=Range("a" & x), Address:=file(i) & f, TextToDisplay:=f
       'ShellExecute 0, "open", file(i) & f, "", "", 1
       'MsgBox (f)
       changeHeaderFooter (file(i) & f)
        x = x + 1
        f = Dir
    Loop
Next
End Sub

Function changeHeaderFooter(ByVal path As String)
    Dim doc As Document
    Dim obLevel As String
    
    Set doc = Documents.Open(path, Visible:=ture)
    
    '选择密级
    obLevel = "秘密▲";
    
   '以下段落用于页眉或页尾作伏笔
    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.ParagraphFormat.Alignment = wdAlignParagraphLeft

    Selection.WholeStory  '全选整个页眉
    Selection.TypeBackspace  '删除整个页眉
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

    '以下段落用于页眉内容设置：
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.TypeText Text:=obLevel   '字符内容
    Selection.MoveLeft Unit:=wdCharacter, Count:=Len(obLevel), Extend:=wdExtend '往左选择
    Selection.Font.Name = "宋体"
    Selection.Font.Size = 10.5     '五号

    '以下段落用于插入页眉图片：WordFlag.jpg->相对应用程序路径下图片
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.InlineShapes.AddPicture FileName:=Application.MacroContainer.path & "\WordFlag.jpg", LinkToFile:=False, SaveWithDocument:=True
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

    'Selection.InlineShapes(1).Height = 34.3  '把插入的照片设置为（34.3），即为1.22厘米
    'Selection.InlineShapes(1).Width = 72.85  '把插入的照片设置为（72.85），即为2.57厘米

    Selection.MoveRight Count:=1 '向右移动一个空格

    Selection.TypeText Text:="                                                 "   '空格，用于图片与上面的“……”等内容隔开来


    Selection.MoveDown Unit:=wdLine, Count:=1  '把光标从页眉转移到页脚来
    Selection.WholeStory  '全选整个页脚
    Selection.TypeBackspace  '删除整个页脚

    '页脚的内容设置
    Selection.TypeText Text:="<以上所有信息均为XXX公司所有>"
    Selection.MoveLeft Unit:=wdCharacter, Count:=29, Extend:=wdExtend
    Selection.Font.Name = "宋体"
    Selection.Font.Size = 9  '小五
    Selection.MoveRight Unit:=wdCharacter, Count:=27
    Selection.TypeText Text:="                                " '27个空格，隔开页码
    '页脚的页码设置
    Selection.TypeText Text:="第"
    ActiveDocument.Fields.Add Selection.Range, wdFieldPage, "Page"
    Selection.TypeText Text:="页"

    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument  '退出页眉和页尾设置
    Application.Browser.Previous
    doc.Close -1, 1
End Function