使用VBA辅助编辑出具有完美导航功能的Word长文档

什么是具有完美导航功能的长文档？至少要具有以下三个特征：

1、有目录，通过点击目录项可以导航到对应章节所在位置；

2、通过点击章节标题，可以返回到对应的目录项所在位置；

3、每页的页眉区显示当页所在章节的标题，点击该标题可以返回到该章节对应的目录所在位置。

语言是无力的，形象是强大的，具体来说就是像下面这个样子的：

怎样做出这种长文档呢？在每个目录项处插入书签，然后在标题处插入链接到书签的超链接，在页眉里插入引用本节标题的域，然后在这个域上再插入链接到书签的超链接。没错，就是这样，但是既然是长文档，完全用手工做，估计很少有人有这么长的生命可供浪费吧？本文将讨论如何利用VBA节约生命......呃，自动帮我们建立节标题和页眉到目录的链接，毕竟目录到节标题的链接是自动建立的。

在讨论VBA之前，需要强调的是，长文档必须要建立大纲结构，也就是说，要为章节标题指定某种标题样式，而且同一级别的标题指定的样式必须相同。本地有所谓金三银七的说法，所以一般文档的标题层级不多的时候，我都使用标题3（wdStyleHeading3）作为每个章节最高等级标题的样式。还有一个要注意的是，不要用空段落（只有回车符没有内容的段落）调整段落之间的纵向间距，而应该使用段落对话框（或者布局面板上的段落命令组，注意要在页面视图中才能找到）中的段前段后行数来调整------当然，不按照这个规则办也没关系，只是你在女神心目中的做事专业的形象会打一些折扣，以及偶尔发生的页面上部出现很多空段落让你不得不一一删除而已。文档编辑完成后，在适当位置自动生成目录，激活任意一页的页眉，插入->文档部件->域，之后如下图（当然样式名要与章节标题的样式一致）：

在上面的基础上就可以让VBA大显身手了。首先是在每个目录项上生成书签，用"toc_"连接数字序号作为书签名（当然也可以用女神名加数字序号，助力幻想无数女神围绕自己的情形，但是要确保不会覆盖已有的标签），代码如下：

vbnet 复制代码

Sub 为目录中指定级别的目录项创建书签()
  Dim aPara As Paragraph, i As Integer, toc As Style, tocLocalName$
  Dim tocRng As Range, rng As Range, doc As Document
  Set doc = ActiveDocument
  ' 指定需要插入标签的目录项样式。目录项样式直接与目录的标题级别挂钩，
  ' 有可能需要个性化修改的就是样式常量末尾的那个数字
  Set toc = doc.Styles(wdStyleTOC3)
  tocLocalName = toc.NameLocal ' 样式的本地名称，避免直接写"TOC 3"之类容易出错
  On Error Resume Next
  ' 选择目录
  Set tocRng = doc.TablesOfContents(1).Range
  ' 变量i用于为目录定义的书签名编序号
  i = 1
  ' 遍历目录项，为toc级标题目录项创建书签
  For Each aPara In tocRng.Paragraphs
    If (aPara.Style = toc Or aPara.Style.NameLocal = tocLocalName) _
        And Len(aPara.Range.Text) > 1 Then
        Set rng = doc.Range(aPara.Range.Start, aPara.Range.End - 1)
        ' 为toc级标题建立书签，命名方式为"toc_"加上序号
        With ActiveDocument.Bookmarks
            .DefaultSorting = wdPosition
            .Add Range:=rng, Name:="toc_" & i
        End With
        i = i + 1
    End If
  Next
End Sub

然后需要在每个章节标题前添加分节符。如果章节内容较短又没有特殊要求，可以考虑添加连续型分节符，章节内容较长则比较适宜添加分页型分节符，即让每一个章节的标题段落直接从下一页开始。为了防止下面代码中的防分节符重复部分不够可靠，执行完后可以打开大纲视图观察一下又没有两个分节符连在一起的情况，或者干脆直接查找替换，将"^b^p^b"及"^b^b"替换成"^b"，执行到直至找不到匹配项为止。

vbnet 复制代码

Sub 在指定级别的标题段落前插入分页型分节符()
    Dim pos As Long, styleName$, tmpRng As Range
    Dim hdrStyle As Style, doc As Document, isBreakPara As Boolean
    Set doc = ActiveDocument
    Set hdrStyle = doc.Styles(wdStyleHeading3) ' 指定的标题级别
    styleName = hdrStyle.NameLocal ' 标题样式的本地样式名称
    
    With Selection
        .HomeKey wdStory '光标回到文档开头，此时Selection.Start为0
        Do
            pos = .Start '先记录光标位置
            .GoTo wdGoToHeading, wdGoToNext, 1 '向后移动到下一个标题，以标题为对象遍历文档
            If .Start = pos Then Exit Do ' 光标位置不变则已遍历完所有标题，退出循环
            
            If .Start > doc.Content.Start Then
                Set tmpRng = doc.Range(.Start - 1, .Start + 1)  ' 为什么要用这个范围？不是拉马努金的灵感，是测试结果
                tmpRng.Find.Text = "^b" ' 分节符
                isBreakPara = tmpRng.Find.Execute  ' 2个字符内都能找到分节符，这就是个只有分节符的段落
'                Debug.Print .Paragraphs(1).Range.Style.NameLocal
'                Debug.Print "isBreakPara = " & isBreakPara
                If (.Paragraphs(1).Style = hdrStyle Or .Paragraphs(1).Style.NameLocal = styleName) And _
                        Not isBreakPara Then ' 避免在前面已有分节符的情况下再插入一个分节符
                        
                    .InsertBreak Type:=wdSectionBreakNextPage ' 插入分页型分节符，其他类型找MSDN文档看常量名称
                End If
            End If
        Loop
    End With
 
End Sub

接下来插入从标题到目录项的超链接：

vbnet 复制代码

Sub 创建标题段落到目录项的链接()
    '
    ' 自动生成的目录只能从目录项链接到标题段落
    ' 此宏通过为一级目录创建书签，再在一级目录
    ' 对应的标题段落处插入到相应书签的链接，从
    ' 而建立标题段落与相应目录项的链接。
    '
      Dim aPara As Paragraph, i As Integer, hdrStyle As Style
      Dim localHdrStyleName$, rng As Range, doc As Document
      Set doc = ActiveDocument
      Set hdrStyle = doc.Styles(wdStyleHeading3)  ' 章节标题的标题级别样式
      localHdrStyleName = hdrStyle.NameLocal ' 章节标题样式的本地样式名称
      On Error Resume Next
      i = 1 ' 标签名中的数字序号
      ' 在每一个样式为hdrStyle的段落插入超链接，目标为相应书签。
      ' 注意在遍历文档段落时分节符也算一个段落，所以要排除空白段落（文本长度为1的段落）
      For Each aPara In ActiveDocument.Paragraphs
        If (aPara.Style = hdrStyle Or aPara.Style.NameLocal = localHdrStyleName) _
                And Len(aPara.Range.Text) > 1 Then
                Set rng = doc.Range(aPara.Range.Start, aPara.Range.End - 1)   '丢掉回车符
            doc.Hyperlinks.Add Anchor:=rng, Address:="", SubAddress:="toc_" & i
            
            i = i + 1
            ' Debug.Print "完成段落数量:" & i
        End If
      Next
      MsgBox "Done!"
End Sub

最后是重头戏，将页眉链接到目录项。

vbnet 复制代码

Sub 在全文页眉的引用标题域外套链接域()
'    先确保已为目录项创建书签，如未创建，取消下面一行的注释。
'    为目录中指定级别的目录项创建书签  ' 注意这是过程名
    Dim doc As Document
    Dim sec As Section
    Dim secIndex As Long
    Dim hdrRange As Range
    Dim fld As Field
    
    Set doc = ActiveDocument
    secIndex = 0
    
    Application.ScreenUpdating = False
    取消页眉链接到上一条页眉
    For Each sec In doc.Sections
        '第一节包含标题先加索引，不包含标题移动到next前面
        secIndex = secIndex + 1
        
        ' 获取页眉区域（Range）
        Set hdrRange = sec.Headers(wdHeaderFooterPrimary).Range
        
        ' 处理三类页眉
        在给定节页眉的引用标题域外套链接域 sec.Headers(wdHeaderFooterPrimary).Range, secIndex
        在给定节页眉的引用标题域外套链接域 sec.Headers(wdHeaderFooterFirstPage).Range, secIndex
        在给定节页眉的引用标题域外套链接域 sec.Headers(wdHeaderFooterEvenPages).Range, secIndex
        
        
    Next sec
    
    MsgBox "完成。共处理节数：" & secIndex & "。", vbInformation
    
    Application.ScreenUpdating = True
End Sub

上面的代码第二行注释中的"为目录中指定级别的目录项创建书签"不是普通的中文注释，而是第一个宏的宏名称。里面还用到了两个宏"取消页眉链接到上一条页眉"和"在给定节页眉的引用标题域外套链接域"，下面分别给出这两个宏：

取消页眉链接到上一条页眉()：

vbnet 复制代码

' 确保当前节的各类页眉不与上一节相同
Sub 取消页眉链接到上一条页眉()
    Dim sec As Section, doc As Document
    Set doc = ActiveDocument
    On Error Resume Next
        
    ' 取消页眉与上一节相同（若已取消不会报错）
    For Each sec In doc.Sections
        sec.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
        sec.Headers(wdHeaderFooterFirstPage).LinkToPrevious = False
        sec.Headers(wdHeaderFooterEvenPages).LinkToPrevious = False
    Next sec
End Sub

在给定节页眉的引用标题域外套链接域(ByVal hdrRange As Range, ByVal secIndex As Long)：

vbnet 复制代码

Private Sub 在给定节页眉的引用标题域外套链接域(ByVal hdrRange As Range, ByVal secIndex As Long)
    If hdrRange Is Nothing Then
        Debug.Print "hdrRange Is Nothing"
        Exit Sub
    End If
    If hdrRange.StoryLength = 0 Then
        Debug.Print "hdrRange.StoryLength = 0 "
        Exit Sub
    End If
    If hdrRange.Fields.Count = 0 Then
        Debug.Print "hdrRange.Fields.Count = 0 "
        Exit Sub
    End If
    
    Dim f As Field, target As Field, firstField As Field
    
    ' 1) 找到页眉中的域。优先找 STYLEREF；找不到则退而求其次用第一个域
    
'    For Each f In hdrRange.Fields
'        If firstField Is Nothing Then Set firstField = f
'        If f.Type = wdFieldStyleRef Then
'            Set target = f
'            Exit For
'        End If
'    Next f
'    If target Is Nothing Then Set target = firstField

    ' 页眉中的域一般是自己插的，就不要学AI搞那么多判断了，粗暴地用第一个域
    ' 做判断的内容注释掉留着,万一有用时可以参考
    Set target = hdrRange.Fields(1)
    
'    If target.Type <> wdFieldStyleRef Then
'            MsgBox "页眉的第一个域不是引用域，请检查页面内容或修改宏代码！"
'            Exit Sub
'        End If
'    If target Is Nothing Then Exit Sub
    
    ' 如果已经是超链接就不再处理，这个留着，以免执行两次宏时重复插入超链接
    If target.Type = wdFieldHyperlink Then Exit Sub
    
    Dim dq As String: dq = ChrW(34) ' "
    
    ' 2) 取原域代码（不含外层花括号），并确定插入位置：用原结果区位置最稳妥
    Dim oldCode As String
    Dim ins As Range
    oldCode = target.Code.Text                      ' 例如： STYLEREF "标题 3" \* MERGEFORMAT
    Set ins = target.Result.Duplicate               ' 在原结果位置插回内容
    
    ' 3) 删除原字段（含花括号）
    target.Delete
    
    ' 4) 插入外层超链接域：{ HYPERLINK \l "con_<secIndex>" }，
    ' 域代码必须用这种形式组装，不能用拼接引号和花括号字符串的方式
    Dim hyperLink As Field
    Set hyperLink = ins.Fields.Add(ins, wdFieldHyperlink, _
             "\l " & dq & "toc_" & secIndex & dq)
    
    Debug.Print "hyperLink=>" & hyperLink.Code
    
    ' 5) 在超链接"结果区"插入内层 STYLEREF 域作为显示文本
    Dim inner As Field
    Set inner = hyperLink.Result.Fields.Add(hyperLink.Result, wdFieldEmpty, oldCode)
    
    ' 6) 更新
    inner.Update
    hyperLink.Update
    ' 新添加的域文字大小会与正文样式相同，恢复一下页眉区的文字大小
    hdrRange.Font.Size = 9
    Debug.Print "secIndex: " & secIndex
End Sub

最后一个宏的代码主要功劳是GPT-5的（windsurf内嵌），我以前写的宏功能没这么强大，修改章节标题时页眉的文字没有跟着变化。