一个多个AI都出错的VBA问题•外一篇：短章节长文档页眉到目录项的链接处理

在编辑某个长文档的时候，我遵照尽量不用空格调整字符的水平间距的原则，将章节标题中的序号的最后一个字与标题第一个字这两个字之间的距离通过“调整宽度”修改为3字符，这样在中间就出现了一个字的空白。但是之后在页眉中插入到标题的引用时，发现页眉显示的文本在序号与标题之间的空白消失了。这是因为STYLEREF 字段默认不会保留被引用文本的格式，包括"调整宽度"等格式设置。看来遵守原则也需要灵活变通。要将这么多“调整宽度”修改为空格分隔，当然不可能用手工来玩了，而在AI如此强大的今天，也不可能动手就自己编代码了，所以让GPT-5给我弄个宏，完成这个任务。然后它洋洋洒洒出了一大篇，我复制过来一运行，然并卵。又换成之前表现不错的SWE-1试一试，还是不行。再换中国的通义千问，也不行，看来还是要自己费心了。

从思路上来说，关键在于定位到用“调整宽度”修改过字符间距的位置。所以这次我不要AI生成完整功能的代码，就问怎么定位到用“调整宽度”修改过字符间距的位置。结果AI们一致建议用range.find查找，当然是查不到，然后又给出一个方案，逐个遍历字符，检查字符的font.scaling属性是不是不等于1。这个主意看来靠谱，试了一下，又是然并卵。继续问AI，就是车轱辘提供然并卵的代码了。翻MSDN文档？那是不可能的。录制宏，使用一下“调整宽度”命令，看看word究竟玩的什么魔法。结果发现修改的是FitTextWidth属性值。自己把代码敲出来？那也是不可能的。告诉AI检查FitTextWidth属性，结果AI统一去检查Font.FitTextWidth属性，当然又是然并卵。不过这次要做的修改就很少了，将Font.FitTextWidth属性改成Range.FitTextWidth属性还是轻而易举的，就不麻烦AI了。代码如下：

Sub 将指定级别标题中的调整宽度转换为空格分隔()

    Dim styleName$, hdrParaRng As Range, charRng As Range
    Dim hdrStyle As Style, doc As Document
    Dim i As Integer
    Set doc = ActiveDocument
    Set hdrStyle = doc.Styles(wdStyleHeading3) ' 指定的标题级别
    styleName = hdrStyle.NameLocal ' 标题样式的本地样式名称
    i = 0
    ' 停止更新屏幕
    Application.ScreenUpdating = False
    
    With Selection
        .HomeKey wdStory '光标回到文档开头，此时Selection.Start为0
        Do
            pos = .Start '先记录光标位置
            .GoToNext wdGoToHeading '因为修改的地方都在标题段落里，以标题为对象遍历文档
            If .Start = pos Then Exit Do ' 光标位置不变则已遍历完所有标题，退出循环
                
                If (.Paragraphs(1).Style = hdrStyle Or .Paragraphs(1).Style.NameLocal = styleName) Then
                     Set hdrParaRng = .Paragraphs(1).Range
                     ' 遍历段落范围内的每一个字
                     For Each charRng In hdrParaRng.Characters
                        ' 检查字的Range的FitTextWidth是否不等于0，即是否使用了“调整宽度”
                        If Not IsNull(charRng.FitTextWidth) And charRng.FitTextWidth <> 0 Then
                            '取消调整宽度
                            charRng.FitTextWidth = 0
                            ' 添加一个空格
                            charRng.Text = charRng.Text & " "
                            i = i + 1
                            Debug.Print "i=" & i
                            ' 只有一处调整过宽度，可以退出循环了
                            Exit For
                        End If
                    Next charRng
                End If
        Loop
    End With
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    MsgBox "转换完成！", vbInformation

End Sub

继续增加点营养。不精益求精不好意思说自己是写程序的人，上次留下了每页开头插入分节符的搞法后，今天弄了个更高效地做法。另外，上次那个按页插入分节符的搞法，也需要加入取消首页不同的处理以消除标题在一页首行时该页不能显示页眉的bug。

更新：word长文档链接跳转处理终极版

前提：

1、文档建立大钢结构，并且最高等级的标题（例如设置标题1为最高等级标题）只有一个，通常放在封面；

2、分页你随意，建议封面与目录、目录与序言、序言与正文等性质不同的部分页，章节之间可以根据实际情况针对性的修改下面的“在指定段落前插入分节符”宏代码，不分页就选择在相关标题处插入连续型分节符的代码，分页就选择插入分页型分节符的代码；

3、如果混用分页型和连续型分节符，分页型分节符较少时可先用手工插入分页型分节符，连续型分节符由代码插入，无需修改代码；如果都比较多，并且有一定规律，请修改插入分节符的相关代码，使其符合需求；如果都比较多且没有规律，请重新规划你的文档排版，或者全部手工插入分节符。

4、如某些等级的目录项无需显示页码（典型的如封面为标题1，页码为0，那么标题1不要显示页码），可以在插入自动目录后项下面这样修改域代码，或者直接用下面的域代码插入目录：

TOC \o "1-3" \h \z \u \n 1-1 \t "标题 1,1,标题 2,2,标题 3,3"

其中，\n开关后的范围即为不显示页码的范围。建议先完成分节符的插入，再插入目录。

分节符的插入有两种方案。第一种方案为在指定等级以上的标题段落前插入分节符（这里均以章节之间不强制分页为例，章节之间需要强制分页只需将代码中的连续型分节符改为分页型分节符）：

Sub 在指定段落前插入分节符()
    Dim pos As Long, styleName$, tmpRng As Range, olLevel%
    Dim hdrStyle As Style, doc As Document, isBreakPara As Boolean
    Set doc = ActiveDocument
    Set hdrStyle = doc.Styles(wdStyleHeading3) ' 指定的标题级别
    styleName = hdrStyle.NameLocal ' 标题样式的本地样式名称
    olLevel = wdOutlineLevel3 '大纲级别
    
    Application.ScreenUpdating = False
    
    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个字符内都能找到分节符，这就是个只有分节符的段落
                ' 高于指定大纲级别的标题段落前插入分节符
                If .Paragraphs(1).OutlineLevel <= olLevel And _
                        Not isBreakPara Then ' 避免在前面已有分节符的情况下再插入一个分节符
'                ' 指定样式的段落前插入分节符
                        
                    '.InsertBreak Type:=wdSectionBreakNextPage ' 插入分页型分节符，MSDN文档或者AI可以提供其他类型分节符常量
                    .InsertBreak Type:=wdSectionBreakContinuous ' 插入连续型分节符
                    
                    Debug.Print "pos=" & pos
                End If
            End If
        Loop
        
        ' 为了不破坏文档大钢结构，将分节符样式改为正文，重要
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        .Find.Replacement.Style = doc.Styles(wdStyleNormal)
        With .Find
            .Text = "^b"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
        End With
        .Find.Execute Replace:=wdReplaceAll

    End With
    Application.ScreenUpdating = True
End Sub

第二种分节方案为在每页开头插入分节符。使用这种方案应当注意，如果分节符刚好插入在一个跨页段落中间，分节符后面的段落会应用原来段落的样式，可能会产生非预期的缩进。典型如在正文段落中间插入分节符，分节符后面的段落可能会产生首行缩进，因此应根据需要创造出一个样式以避免分节符后面的段落格式不满足要求。代码如下：

Sub 每页插入连续型分节符()
    Dim doc As Document
    Dim selPos As Long
    Dim nextPara As Paragraph
    Dim inPara As Boolean, styleName$
    Dim tmpRng As Range
    Dim isBreakPara As Boolean
    
    Set doc = ActiveDocument
    styleName = "无首行缩进段落"
    
    ' 停止更新屏幕
    Application.ScreenUpdating = False
    
    With Selection
        .HomeKey wdStory
        Do
            selPos = .Start
            .GoTo What:=wdGoToPage, Which:=wdGoToNext
            If .Start = selPos Then Exit Do
        
            Set tmpRng = doc.Range(.Start - 1, .Start + 1)  ' 为什么要用这个范围？不是拉马努金的灵感，是测试结果
            tmpRng.Find.Text = "^b" ' 分节符
            isBreakPara = tmpRng.Find.Execute  ' 2个字符内都能找到分节符，这就是个只有分节符的段落
            If Not isBreakPara Then ' 如果页面开头不是分节符
                ' 检查当前位置是否在段落中间
                inPara = Selection.Start > Selection.Paragraphs(1).Range.Start And _
                    Selection.Start < Selection.Paragraphs(1).Range.End - 1
                
                ' 在光标位置插入分节符
                .InsertBreak Type:=wdSectionBreakContinuous
                
                .MoveRight
                ' 获取分节符后的段落
                Set nextPara = .Paragraphs(1)
                    
                ' 检查段落是否存在且不为空
                If inPara And Not nextPara Is Nothing Then
                    '检查是否存在"无缩进段落"样式
                    Dim targetStyle As Style
                    On Error Resume Next
                    Set targetStyle = doc.Styles(styleName)
                    On Error GoTo 0
                        
                    If Not targetStyle Is Nothing Then
                        ' 应用"无缩进段落"样式
                        nextPara.Style = targetStyle
                    Else
                        ' 如果"无缩进段落"样式不存在，可以选择其他处理方式
                        Debug.Print "警告: 未找到'无缩进段落'样式，页 " & currentPage
                    End If
                End If
            End If
        Loop
        ' 为了不破坏文档大钢结构，将分节符样式改为正文，重要
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        .Find.Replacement.Style = doc.Styles(wdStyleNormal)
        With .Find
            .Text = "^b"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
        End With
        .Find.Execute Replace:=wdReplaceAll
    End With
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    MsgBox "每页开头已插入连续型分节符！", vbInformation
End Sub

分节符如果在标题段落前面插入，分节符本身的大纲级别会与标题段落的大纲级别相等，这就会破坏文档的原有大纲结构，因此，上述代码中的将分节符样式替换为正文必不可少，否则可能出现页眉标题引用错误。

5、在插入目录后运行下面的宏为所有目录项创建书签，以作为链接的目标。这里采用不同级别的目录项分别编号的方式创建书签，以便于后续区分不同等级的标题链接。这里处理了目录包含三级标题的情况，如果标题等级数量不同请适当修改代码。

Sub 为所有目录项创建书签()
    Dim aPara As Paragraph, i As Integer, preBookMk$
    Dim tocRng As Range, rng As Range, doc As Document
    Dim reSpace, reNum As RegExp
    Dim t1%, t2%, t3%, tNum%
    
    Set doc = ActiveDocument
    Set reSpace = New RegExp
    Set reNum = New RegExp
    With reSpace
        .Pattern = "[\s]"
        .Global = True
    End With
    With reNum
        .Pattern = "[^0-9]"
        .Global = True
    End With

    On Error Resume Next
    ' 选择目录
    Set tocRng = doc.TablesOfContents(1).Range
    t1 = 0: t2 = 0: t3 = 0
    ' 遍历目录项，为所有目录项创建书签
    For Each aPara In tocRng.Paragraphs
        If Len(aPara.Range.Text) > 1 Then
            Set rng = doc.Range(aPara.Range.Start, aPara.Range.End - 1)
            ' 目录项样式名中的空格删除并统一为小写字母，形如toc#，#表示数字
            preBookMk = LCase(reSpace.Replace(aPara.Style.NameLocal, ""))
            ' 提取目录项样式名中的数字
            tNum = Int(reNum.Replace(preBookMk, ""))
            If tNum = 1 Then
                t1 = t1 + 1
                i = t1
            ElseIf tNum = 2 Then
                t2 = t2 + 1
                i = t2
            ElseIf tNum = 3 Then
                t3 = t3 + 1
                i = t3
            End If
            ' 书签命名方式为“toc#_序号”，#表示数字
            With ActiveDocument.Bookmarks
                .DefaultSorting = wdPosition
                .Add Range:=rng, Name:=preBookMk & "_" & i
            End With
            Debug.Print "创建书签：" & preBookMk & "_" & i
        End If
    Next
End Sub

6、用下面的宏插入标题段落到目录项的超链接。这里的关键及巧是使用

Selection.GoToNext wdGoToHeading

来遍历文档，并通过执行前后光标位置是否变化来判断是否已完成遍历。这比通过数字序号遍历文档所有节以及按段落遍历文档并检查段落的样式进行操作效率都要高不少。如果目录项中包含的标题等级不是3级，同样需要适当修改代码。

Sub 标题段落到目录项的链接()
    '
    ' 自动生成的目录只能从目录项链接到标题段落
    ' 此宏需要先为所有目录项创建书签，再依次在
    ' 标题段落处插入到相应书签的链接，从而建立
    ' 标题段落与相应目录项的链接。
    '
    Dim doc As Document, titleParaRng As Range
    Dim i%, pos As Long, aSec As Section, txt$
    Dim t1%, t2%, t3%, olLevel%, subAddr$
    
    Set doc = ActiveDocument
    
    t1 = 0: t2 = 0: t3 = 0
    Application.ScreenUpdating = False
    
    With Selection
        .HomeKey wdStory
        Do
            olLevel = .Paragraphs(1).OutlineLevel
            ' 段落大纲级别不足时跳转到大纲级别符合要求的段落
            While olLevel > wdOutlineLevel3
                pos = .Start
                .GoToNext wdGoToHeading
                If .Start = pos Then Exit Do
            Wend
            olLevel = .Paragraphs(1).OutlineLevel
            ' 在大纲级别符合要求的段落插入到页眉的超链接
            Set titleParaRng = doc.Range(.Paragraphs(1).Range.Start, .Paragraphs(1).Range.End - 1)
            txt = titleParaRng.Text
            If olLevel = wdOutlineLevel1 Then
                t1 = t1 + 1
                i = t1
            ElseIf olLevel = wdOutlineLevel2 Then
                t2 = t2 + 1
                i = t2
            ElseIf olLevel = wdOutlineLevel3 Then
                t3 = t3 + 1
                i = t3
            End If
            If Len(txt) > 0 Then
                subAddr = "toc" & olLevel & "_" & i
                ' 如果已在标题段落插入了链接，先删除
                If titleParaRng.Hyperlinks.Count > 0 Then
                    titleParaRng.Hyperlinks(1).Delete
                End If
                doc.Hyperlinks.Add Anchor:=titleParaRng, Address:="", _
                    SubAddress:=subAddr
            End If
            
            Debug.Print "完成标题：" & txt
            ' 跳到下一个标题段落，光标位置不变则退出循环
            pos = .Start
            .GoToNext wdGoToHeading
            If .Start = pos Then Exit Do
        Loop
    End With
    
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub

7、在插入页眉到目录项的超链接时，如果是在标题段落前插入的分节符，那么处理起来要简单一些，代码如下：

Sub 每节页眉插入链接到目录项的超链接()

    ' 此宏运行前需：
    ' 1、为所有目录项创建书签
    ' 2、在不低于指定大纲级别的标题段落前插入分节符
    
    Dim doc As Document, firstPara As Paragraph
    Dim i As Integer, aSec As Section, txt$
    Dim olLevel%, hdftRange As Range
    Dim regEx As Object, target As Field
    Dim t1%, t2%, t3%, secNum%, subAddr$
    
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        ' 标题中的某些字符在页眉中可能无法正常显示，下面设置的是需要保留的字符
        .Pattern = "[^0-9a-zA-Z〇,·?，？！!\u201c\u201d\u4e00-\u9fa5\u00C0-\u00FF\s]"
        .Global = True
    End With
    
    Set doc = ActiveDocument
    
    t1 = 0: t2 = 0: t3 = 0
    secNum = 0: i = 0
    ' 停止更新屏幕
    Application.ScreenUpdating = False
    
    For Each aSec In doc.Sections
        Set firstPara = aSec.Range.Paragraphs(1)
        olLevel = firstPara.OutlineLevel
        If olLevel <= 3 Then
            
            ' 获取章节标题文本。
            txt = doc.Range(firstPara.Range.Start, firstPara.Range.End - 1).Text
            txt = regEx.Replace(txt, "") ' 将页眉中无法显示的字符删除
            
            ' 页眉禁止链接到上一节，可分拆出去先执行
            aSec.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
            aSec.Headers(wdHeaderFooterFirstPage).LinkToPrevious = False
            aSec.Headers(wdHeaderFooterEvenPages).LinkToPrevious = False
            
            If olLevel = 1 Then
                t1 = t1 + 1
                i = t1
            ElseIf olLevel = 2 Then
                t2 = t2 + 1
                i = t2
            ElseIf olLevel = 3 Then
                t3 = t3 + 1
                i = t3
            End If
            secNum = secNum + 1
            
            Debug.Print "第" & secNum & "节，标题：" & txt
            ' 首节如果是封面可以设定页眉页脚首页不同，其余各节禁用页眉页脚首页不同和奇偶页不同
            If olLevel > 1 Then
                ' 这些设置可以拆分出取先执行，以减少这个宏的执行时间
                With aSec.PageSetup
                    ' 禁用"首页不同"选项
                    .DifferentFirstPageHeaderFooter = False
                    ' 禁用"奇偶页不同"选项
                    .OddAndEvenPagesHeaderFooter = False
                End With
                ' 设置页脚页码续前节
                With aSec.Footers(wdHeaderFooterPrimary).PageNumbers
                    .RestartNumberingAtSection = False
                    .StartingNumber = wdContinueNumbering
                End With
                ' 如果文档有首页不同或奇偶页不同，也需要设置对应的页脚
'                With aSec.Footers(wdHeaderFooterFirstPage).PageNumbers
'                    .RestartNumberingAtSection = False
'                    .StartingNumber = wdContinueNumbering
'                End With
'
'
'                With aSec.Footers(wdHeaderFooterEvenPages).PageNumbers
'                    .RestartNumberingAtSection = False
'                    .StartingNumber = wdContinueNumbering
'                End With
                
            
                subAddr = "toc" & olLevel & "_" & i
                Set hdftRange = aSec.Headers(wdHeaderFooterPrimary).Range
                ' 操作页眉。比较奇葩的是先插入超链接再插入tab最后插入标题引用，显示的顺序
                ' 居然是反过来的。不知道是不是所有Word版本都是这样。如果你的版本不是这样，
                ' 可以交换插入标题引用与插入超链接的位置，最后一个Direction:=wdCollapseStart
                ' 也改成Direction:=wdCollapseEnd。
                With hdftRange
                    ' 清空原有页眉内容，确保格式纯净
                    .Delete
                    ' 在页眉右边插入超链接域，显示文本为最新取得的章节标题文本
                    ' 因为同一页面有多个分节符时可能引起标题引用取值混乱，所以
                    ' 没有采取左边域的嵌套方式，而是直接插入超链接
                    doc.Hyperlinks.Add Anchor:=hdftRange, Address:="", _
                        SubAddress:=subAddr, TextToDisplay:=txt
    
                    ' 插入1个Tab键（使页眉区域的两个域左右分开）
                    .Collapse Direction:=wdCollapseEnd ' 光标移到域末尾
                    .Text = vbTab ' 插入Tab字符
    
                    ' 插入页眉左边的域
                    ' 1）插入【引用标题】的域
                    .Collapse Direction:=wdCollapseStart
                    Dim styleName$  ' 从系统中取本地样式名，避免样式名输入错误
                    styleName = IIf(secNum = 2 Or olLevel = 2, _
                        doc.Styles(wdStyleHeading1).NameLocal, _
                        doc.Styles(wdStyleHeading2).NameLocal)
                    Set target = .Fields.Add( _
                        Range:=hdftRange, _
                        Type:=wdFieldStyleRef, _
                        Text:="""" & styleName & """", _
                        PreserveFormatting:=False) ' 不保留标题2原格式，适配页眉样式
                    ' 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 "toc_<secIndex>" }，
                    ' 域代码必须用这种形式组装，不能用拼接引号和花括号字符串的方式
                    Dim hyperLink As Field, sToc$
                    sToc = IIf(secNum = 2 Or olLevel = 2, _
                        "toc1_" & t1, "toc2_" & t2)
                    Set hyperLink = ins.Fields.Add(ins, wdFieldHyperlink, _
                            "\l " & dq & sToc & dq)
        
                    ' 5) 在超链接“结果区”插入内层 STYLEREF 域作为显示文本
                    hyperLink.Result.Fields.Add hyperLink.Result, wdFieldEmpty, oldCode
                    
                    ' 设置右对齐制表位
                    ' 1. 定义制表位位置：A4纸横向页眉宽度约595磅，设为466磅（靠右且不溢出，可按需调整）
                    tabpos = 466
                    ' 2. 清除原有制表位，添加新的“右对齐制表位”
                    With .ParagraphFormat.TabStops
                        .ClearAll ' 清除默认制表位，避免干扰
                        ' 添加右对齐制表位（位置=tabPos，对齐方式=右对齐，无前导符）
                        .Add Position:=tabpos, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderNone
                    End With
                
                    ' 设置页眉整体左对齐（确保段落基础对齐方式正确）
                    .ParagraphFormat.Alignment = wdAlignParagraphLeft
                    
                    ' 更新所有域，确保标题引用生效
                    .Fields.Update
                End With
                aSec.Headers(wdHeaderFooterPrimary).Range.Font.Size = 9
            End If
        End If
    Next aSec
    ' 删除第一节（封面）的页眉
    doc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Delete
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    MsgBox "页眉到目录项的超链接完成！", vbInformation

End Sub

对于章节之间强制分页的文档，应当使用上面的方法。章节之间没有强制分页时，除了在 标题段落前分节外，还可以采用在每页开头插入的分节符的方式，用这种方式插入分节符，页眉到目录项之间的链接使用如下代码：

Sub 按页分节页眉插入链接到目录项()
    Dim doc As Document, aSec As Section
    Dim hdftRange As Range
    Dim head2Index, head3Index As Long
    Dim withinHead2, withinHead3, headerSeted As Boolean
    Dim linkAddr$, aPara As Paragraph
    
    ' 设置文档和集合
    Set doc = ActiveDocument
    head2Index = 0: head3Index = 0
    withinHead2 = False: withinHead3 = False
    
    ' 遍历每个节
    For Each aSec In doc.Sections
        ' 禁止页眉链接到上一节
        aSec.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
        aSec.Headers(wdHeaderFooterFirstPage).LinkToPrevious = False
        aSec.Headers(wdHeaderFooterEvenPages).LinkToPrevious = False
        
        Set hdftRange = aSec.Headers(wdHeaderFooterPrimary).Range
        hdftRange.Text = ""
        hdftRange.Collapse wdCollapseEnd
        headerSeted = False
        For Each aPara In aSec.Range.Paragraphs
            If aPara.OutlineLevel > 1 Then
                If aPara.OutlineLevel = 2 Then
                    withinHead2 = True
                    withinHead3 = False
                    head2Index = head2Index + 1
                    linkAddr = "toc2_" & head2Index
                    insertField wdStyleHeading2, hdftRange, linkAddr
                        
                    Debug.Print linkAddr & "->" & Left(aPara.Range.Text, Len(aPara.Range.Text) - 1)
                    
                    hdftRange.Collapse wdCollapseEnd
                    hdftRange.Text = vbTab ' 插入tab，分开页眉的左边和右边
                    hdftRange.Collapse wdCollapseStart
                    
                    ' 插入引用标题1的域
                    insertField wdStyleHeading1, hdftRange, "toc1_1"
                    GoTo continueForSec
                ElseIf aPara.OutlineLevel = 3 Then
                    withinHead2 = False
                    withinHead3 = True
                    head3Index = head3Index + 1
                    If Not headerSeted Then
                        headerSeted = True
                        linkAddr = "toc3_" & head3Index
                        insertField wdStyleHeading3, hdftRange, linkAddr
                        
                        Debug.Print linkAddr & "->" & Left(aPara.Range.Text, Len(aPara.Range.Text) - 1)
                        
                        hdftRange.Collapse wdCollapseEnd
                        hdftRange.Text = vbTab
                        hdftRange.Collapse wdCollapseStart
                            
                        If head2Index = 0 Then ' 前面没有标题2，左边插入标题1
                            insertField wdStyleHeading1, hdftRange, "toc1_1"
                        Else ' 前面有标题2，左边插入标题2
                            linkAddr = "toc2_" & head2Index
                            insertField wdStyleHeading2, hdftRange, linkAddr
                        End If
                    End If
                End If
            Else
                GoTo continueForSec
            End If
            
        Next aPara
        If Not headerSeted Then
            If withinHead2 Then
                linkAddr = "toc2_" & head2Index
                insertField wdStyleHeading2, hdftRange, linkAddr
                
                hdftRange.Collapse wdCollapseEnd
                hdftRange.Text = vbTab ' 插入tab，分开页眉的左边和右边
                hdftRange.Collapse wdCollapseStart
                
                ' 插入引用标题1的域
                insertField wdStyleHeading1, hdftRange, "toc1_1"
                headerSeted = True
            ElseIf withinHead3 Then
                linkAddr = "toc3_" & head3Index
                insertField wdStyleHeading3, hdftRange, linkAddr
                
                hdftRange.Collapse wdCollapseEnd
                hdftRange.Text = vbTab
                hdftRange.Collapse wdCollapseStart
                    
                If head2Index = 0 Then ' 前面没有标题2，左边插入标题1
                    insertField wdStyleHeading1, hdftRange, "toc1_1"
                Else ' 前面有标题2，左边插入标题2
                    linkAddr = "toc2_" & head2Index
                    insertField wdStyleHeading2, hdftRange, linkAddr
                End If
                headerSeted = True
            End If
        End If
            
continueForSec:
    Next aSec
    
    MsgBox "页眉超链接插入完成！", vbInformation
End Sub

Private Sub insertField(ByVal headStyle As Integer, ByVal rng As Range, ByVal linkAddr As String)
    Dim styleName$, target As Field
    styleName = ActiveDocument.Styles(headStyle).NameLocal
    Set target = rng.Fields.Add( _
        Range:=rng, _
        Type:=wdFieldStyleRef, _
        Text:="""" & styleName & """", _
        PreserveFormatting:=False)
        wrapStyleRefInHyperLink rng, target, linkAddr
End Sub

Private Sub wrapStyleRefInHyperLink(ByVal hdrRange As Range, ByVal target As Field, linkAddr As String)
    
    Dim dq As String: dq = ChrW(34) ' "
    Dim oldCode As String
    Dim ins As Range
    Dim inner As Field

    ' 如果已经是超链接就不再处理，这个留着，以免执行两次宏时重复插入超链接
    If target.Type = wdFieldHyperlink Then Exit Sub
    
    
    ' 1) 取原域代码（不含外层花括号），并确定插入位置：用原结果区位置最稳妥
    oldCode = target.Code.Text                      ' 例如： STYLEREF "标题 3" \* MERGEFORMAT
    Set ins = target.Result.Duplicate               ' 在原结果位置插回内容
    
    ' 2) 删除原字段（含花括号）
    target.Delete
    
    ' 3) 插入外层超链接域：{ HYPERLINK \l "toc_<secIndex>" }，
    ' 域代码必须用这种形式组装，不能用拼接引号和花括号字符串的方式
    Dim hyperLink As Field
    Set hyperLink = ins.Fields.Add(ins, wdFieldHyperlink, _
            "\l " & dq & linkAddr & dq)
    
    Debug.Print "hyperLink=>" & hyperLink.Code
    
    ' 4) 在超链接“结果区”插入内层 STYLEREF 域作为显示文本
    Set inner = hyperLink.Result.Fields.Add(hyperLink.Result, wdFieldEmpty, oldCode)
    
    ' 5) 更新
    inner.Update
    hyperLink.Update
End Sub

其中定义了两个子过程使减少了重复代码。这两种分节方式的区别在于：前一种分节方式中，页面顶端不是分节符后的标题段落时，页眉显示的标题是上一节的标题，后一种分节方式中，页眉显示的标题是本页的第一个标题，如下图所示：

8、上面的宏运行完毕后，正常情况下页眉会显示相应的标题，点击可以跳转到相应的目录项。如果发现某些页面的页眉为空白，特别是第二种分节方式所有页眉全部为空白的话，应当是页面设置选项中“首页不同”或“奇偶页不同”选项起了作用，可以运行下面的宏予以解决：

Sub 页面设置选项()
    Dim aSec As Section
    For Each aSec In ActiveDocument.Sections
        With aSec.PageSetup
            ' 禁用"首页不同"选项
            .DifferentFirstPageHeaderFooter = False
            ' 禁用"奇偶页不同"选项
            .OddAndEvenPagesHeaderFooter = False
        End With
        ' 设置页脚页码续前节
        With aSec.Footers(wdHeaderFooterPrimary).PageNumbers
            .RestartNumberingAtSection = False
            .StartingNumber = wdContinueNumbering
        End With
    Next aSec
    ' 处理第一节（封面）
    With ActiveDocument.Sections(1)
        ' 启用"首页不同"选项
        .PageSetup.DifferentFirstPageHeaderFooter = True
        ' 删除第一节（封面）的页眉
        .Headers(wdHeaderFooterPrimary).Range.Delete
    End With
End Sub

9、插入的页眉如果格式不满意，可以通过修改某个页眉的格式，然后选择该页眉，在样式中找到“页眉”并右键单击，然后选择“更新 页眉 以匹配所选内容”命令即可。页眉中的内容如果没有分居左右，应当是页眉中的制表位布置错误，可以用下面的宏解决（其中制表位位置tabpos的值适用于是A4页面左边留空白2.5cm右边留空白2.0cm，此时制表位刚好处于页面右边边缘。页面设置不同可按每磅约0.353mm或每毫米约2.83磅折算后进行修改调整）：

Sub 页眉制表位设置()
    Dim aSec As Section, tabpos As Single
    For Each aSec In ActiveDocument.Sections
        ' 设置右对齐制表位
        ' 1. 定义制表位位置：A4纸横向页眉宽度约595磅，设为466磅（靠右且不溢出，可按需调整）
        tabpos = 466
        With aSec.Headers(wdHeaderFooterPrimary).Range
            ' 2. 清除原有制表位，添加新的“右对齐制表位”
            With .ParagraphFormat.TabStops
                .ClearAll ' 清除默认制表位，避免干扰
                ' 添加右对齐制表位（位置=tabPos，对齐方式=右对齐，无前导符）
                .Add Position:=tabpos, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderNone
            End With
        
            ' 设置页眉整体左对齐（确保段落基础对齐方式正确）
            .ParagraphFormat.Alignment = wdAlignParagraphLeft
            .Font.Size = 9
        End With
    Next aSec
End Sub

10、标题及页眉插入的超链接文字颜色、下划线等格式默认会发生变化，如不满意，修改样式中的“超链接”和“已访问过的超链接”两个样式的相关格式即可。下面这张图是代码没升级前的结果，页眉只有当前页面最低级别的标题。

特别需要注意的事，由于页眉到目录项的链接目标书签依赖使用标题文本在标题集合中查找到的索引构造，因此必须保持同一级别的标题文本没有相同的情况，否则会导致相同的标题都会链接到最先出现的目录项上。如果文档中确有相同大纲级别的标题文本相同，可以故意增加一些内容使其不同，例如末尾加不同数量的扥这种基本不会用到的字，编辑完成后再将扥全部替换掉，更新域后页眉中的文本会与替换后的标题保持一致。如果标题中有一些特殊字符，还可以在创建标题集合和取标题文本时用正则表达式剔除一些特殊字符，以保证可以准确查到标题文本在集合中的索引。