用VBA在Word文档中每页页眉插入返回文档目录中相应位置的超链接

yivifu

已于 2023-01-17 18:20:28 修改

阅读量1.5k

点赞数 1

分类专栏： VBA 办公软件文章标签： word

于 2022-12-06 20:31:04 首次发布

本文链接：https://blog.csdn.net/yivifu/article/details/128209073

版权

办公软件同时被 2 个专栏收录

21 篇文章 2 订阅

订阅专栏

VBA

19 篇文章 2 订阅

订阅专栏

【说明】此文中在页眉插入跳转到目录项的超链接的代码几经改进，但改进后并未删除改进之前的代码，是为了有个对比利于学习。如果想节约时间，该步骤可直接查看该部分最后一个代码块。
对于Word长文档，标准做法是按文章结构为不同段落指定不同大纲级别的样式，方便插入目录并在文档中灵活跳转到所需内容。这样的文档在Word中编辑或查阅固然方便跳转，但是一旦转换为pdf文档，阅读时跳转就不方便了，需要不停地滚动页面。
在文档中插入自动目录，转换为pdf文件后可以方便从目录跳转到相应内容处，但要想返回目录就只能靠手工翻页或者先为pdf文件创建书签目录。如果在编辑Word文档时事先就建立标题段落到目录项的链接，并在每页的页眉也插入超链接，链接到本页所属标题段落对应的目录项，那么转换为pdf文件后在任意页面都可以很方便地返回对应的目录区域。
如下图中的文档自动生成的目录：
在这里插入图片描述
点击其中的目录项“一、域应用基础”，可以很方便地跳到对应的大纲级别为1、样式名称为“标题 1”的段落所在位置，如下图：

但是点击图中的“标题 1”段落“一、域应用基础”，无法返回目录中相应的目录项。此外，如果在这一小节中阅读几页后，就无法直观地看出当前页面属于哪一节的内容（可以通过在页眉中插入styleref域实现这个功能，但styleref域无法实现超链接功能），当然也无法通过点击文档中的内容跳回目录。再看下面这个页面：
在这里插入图片描述
从页面右上角可以很清楚地看到当前内容属于“二、域速查一览”这一节，如果想跳转到其他章节，也可以方便地点击页眉中的超链接回到目录，再从目录中跳转到其他章节。完成上图中的效果需要文档符合以下要求：
1、每个章节的标题指定了“标题 1”样式，且文档中不存在样式为“标题 1”的空行；
2、在每个章节的标题前插入了分页型分节符。
如果文档符合上述要求，通过以下四个步骤即可实现上图中的效果：
1、在文档中插入自动目录，此步骤可通过引用面板上的目录工具完成。
2、在自动目录的目录项处插入书签。
3、在各节标题处插入跳转到到对应目录项的超链接。
4、在各节页眉处插入跳转到到对应目录项的超链接。
以下介绍使用VBA完成第2、3、4步的方法。三个步骤可以在一个宏里完成，但是文档如果很长，执行时间可能也很长，易出问题，而且很难做到以最高效率完成每一个步骤，因此用三个宏分步执行。

下面的VBA代码完成在自动目录的目录项处插入书签的功能（仅在一级目录处插入书签），原理参见代码注释：

Sub 为自动生成的目录中的目录项创建书签()
  Dim aPara As Paragraph, i As Integer
  On Error Resume Next
  ' 选择目录
  ActiveDocument.TablesOfContents(1).Range.Select
  ' 变量i用于为目录定义的书签名编序号
  i = 1
  ' 遍历目录项，为一级标题目录项创建书签
  For Each aPara In Selection.Paragraphs
    If aPara.Style = "TOC 1" And Len(aPara.Range.Text) > 1 Then
    	' 为一级标题建立书签，命名方式为“con_”加上序号
        With ActiveDocument.Bookmarks
            .DefaultSorting = wdPosition
            .Add Range:=aPara.Range, _
            name:="con_" & i
        End With
        i = i + 1
    End If
  Next
End Sub

从各章节标题跳回目录

下面的VBA代码在各章节的标题处插入跳转到上一个宏生成的书签的超链接，从而提供从各章节标题跳回目录的功能：

Sub 创建标题段落到目录项的链接()
'
' 自动生成的目录只能从目录项链接到标题段落
' 此宏通过为一级目录创建书签，再在一级目录
' 对应的标题段落处插入到相应书签的链接，从
' 而建立标题段落与相应目录项的链接。
'
  Dim aPara As Paragraph, i As Integer
  On Error Resume Next
  i = 1
  ' 在每一个样式为“标题 1”的段落插入超链接，目标为相应书签。
  ' 注意在遍历文档段落时分节符也算一个段落，所以要排除空白段落（文本长度为1的段落）
  For Each aPara In ActiveDocument.Paragraphs
    If aPara.Style = "标题 1" And Len(aPara.Range.Text) > 1 Then
        ActiveDocument.Hyperlinks.Add Anchor:=aPara.Range, Address:="", _
        SubAddress:="con_" & i
        i = i + 1
    End If
  Next
End Sub

再补充一种效率更高的方式。上面的代码是遍历文档中所有段落，下面的代码直接在文档的标题段落中跳转，省去了对正文段落的判断：

Sub 创建标题段落到目录项的链接v2()
	Dim i As Integer, title As String
    ' 变量title用于保存标题文本，初始值用一个不是文档标题的字符串即可，空字符串也行
    title = ""
    ' 变量i用于计算书签编号
    i = 1
	' 禁止屏幕更新，避免光标跳转时屏幕滚动影响效率
    Application.ScreenUpdating = False
    With Selection
        ' 光标回到文档开头
        .HomeKey unit:=wdStory
        Do
            ' 光标移动到下一个标题段落处
            .GoTo what:=wdGoToHeading, which:=wdGoToNext
            ' 选择该标题段落全部内容
            .MoveDown unit:=wdParagraph, Extend:=wdExtend
            ' 标题段落样式为“标题 1”且不是空白段落（排除分节符段落）则插入超链接
            If .Paragraphs(1).Style = "标题 1" And Len(.Range.Text) > 1 Then
                ' 插入超链接
                ActiveDocument.Hyperlinks.Add Anchor:=.Range, Address:="", _
                    SubAddress:="con_" & i
                i = i + 1
            End If
            ' 标题段落文本不发生变化时认定处理完成，退出循环
            ' 这种判别方法只适用于不存在两个连续标题段落文本相同的情况
            If title = .Range.Text Then
                Exit Do
            Else
                ' 保存标题段落文本
                title = .Range.Text
            End If
            ' 以下比较当前光标所在节的编号与总节数，如果相等推定操作完成，退出循环
            ' 这样判断只适用于最后一节只有一个非空白“标题 1”段落的情况，可省去取存标题文本的操作，效率更高。
            ' 如果最后一节有多个非空白“标题 1”段落，则只有第一个段落会被处理，后续段落会被遗漏
            ' If Selection.Information(wdActiveEndSectionNumber) = activedocument.Sections.Count Then
            '     Exit Do
            ' End If
        Loop
    End With
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

在每页页眉中插入到目录项的超链接

以下是在页眉中插入跳转到相应一级目录项的超链接的代码，同样有详尽注释：

Sub 页眉中插入到相应一级目录项的链接()
'
' 此宏在Word文档中每页页眉插入返回文档目录中相应位置的超链接
' 超链接显示的文本为当前页面所属章节的标题
' 此宏顺利执行的前提：
'      1、每个章节的标题指定了“标题 1”样式
'      2、在每个章节的标题前插入了分节符
'      3、文档中插入了自动目录，运行本文第一个宏为每个一级标题目录项生成了
'   形如“con_”加数字序号的书签。
'
    Dim disText As String, secCount, i As Integer
    i = 1
    ' 禁止屏幕滚动以提高效率，执行文档内容插入与修改一般应当这样做
    Application.ScreenUpdating = False
    ' 将页面视图激活区域指定为主文档
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    ' 取得文档分节总数
    secCount = ActiveDocument.Sections.Count
    ' 光标移至文档开头
    Selection.HomeKey unit:=wdStory
    Do
        ' 将光标移动到下一个大纲级别为1的段落
        While Selection.Paragraphs(1).OutlineLevel > 1
            ' 将光标移动到下一个标题段落，直至大纲级别为1停止循环
            Selection.GoTo what:=wdGoToHeading, which:=wdGoToNext, Count:=1
        Wend
        ' 取得段落的文本，前面加上tab键，并去掉结尾的回车符
        disText = Selection.Paragraphs(1).Range.Text
        disText = vbTab & Left(disText, Len(disText) - 1)
        ' 将页面视图激活区域指定为页眉，完成页眉编辑后恢复为主文档
        With ActiveWindow.ActivePane.View
            .SeekView = wdSeekCurrentPageHeader
            ' 取消将页眉链接到上一节，各节独立设置页眉
            Selection.HeaderFooter.LinkToPrevious = False
            ' 插入超链接
            ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
        SubAddress:="con_" & i, ScreenTip:="", TextToDisplay:=disText
            i = i + 1
            .SeekView = wdSeekMainDocument
        End With
        ' 当前光标所在节的编号与总节数相等，意味着已操作完最后一节，退出循环
        If Selection.Information(wdActiveEndSectionNumber) = secCount Then
            Exit Do
        End If
        ' 光标移动到下一节
        Selection.GoTo what:=wdGoToSection, which:=wdGoToNext, Count:=1
    Loop
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
   
End Sub

下面是采用Selection.Move方法实现在每页页眉中插入到目录项的超链接：

Sub 页眉中插入到相应一级目录项的链接()
'
' 此宏在Word文档中每页页眉插入返回文档目录中相应位置的超链接
' 超链接显示的文本为当前页面所属章节的标题
' 此宏顺利执行的前提：
'      1、每个章节的标题制定了“标题 1”样式
'      2、在每个章节的标题前插入了分节符
'      3、文档中插入了自动目录，运行本文第一个宏为每个一级标题目录项生成了
'   形如“con_”加数字序号的书签。
'
    Dim disText As String, i As Integer, aPara As Paragraph
    i = 1
    ' 禁止屏幕滚动以提高效率，执行文档内容插入与修改一般应当这样做
    Application.ScreenUpdating = False
    ' 将页面视图激活区域指定为主文档
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    With Selection
        ' 光标移动至文档开头
        .HomeKey unit:=wdStory    
        Do
            ' 将光标向前移动一个段落，并记录移动数量
            moved = .Move(unit:=wdParagraph, Count:=1)
            ' selection.move方法返回0表示无法再向前移动，文档已处理完成，退出循环
            If moved < 1 Then
                Exit Do
            End If
            disText = .Paragraphs(1).Range.Text
            ' 判断光标所在段落的样式名称及是不是空行
            If .Paragraphs(1).Style = "标题 1" And Len(disText) > 1 Then
                With ActiveWindow.ActivePane.View
                    .SeekView = wdSeekCurrentPageHeader
                    ' 取消将页眉链接到上一节，各节独立设置页眉
                    Selection.HeaderFooter.LinkToPrevious = False
                    ' 删除链接前一节页眉生成的页眉
                    Selection.Paragraphs(1).Range.Delete
                    ' 插入超链接
                    ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
                SubAddress:="con_" & i, ScreenTip:="", TextToDisplay:=vbTab & Left(disText, Len(disText) - 1)
                    i = i + 1
                    .SeekView = wdSeekMainDocument
                End With
            End If
        Loop
    End With    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True   
End Sub

上面的代码每次向下移动一个段落，因此效率较低。如果直接将光标移动到下一节，毫无疑问可以提高效率。但是Selection.Move方法不能使用wdSection为参数unit赋值，只有Selection.GoTo方法才可以通过为what参数赋值为wdSection在节之间移动光标。然而，与Selection.Move方法返回移动数量不同的是，Selection.GoTo方法返回一个Range，如何判断已经全部处理完并退出循环是个问题。经测试发现，在移动到最后一节后，Selection.GoTo what:=wdGoToSection, which:=wdGoToNext语句将使光标一直停留在最后一节开头，因此，可以先将各节标题文本保存起来，如果执行Selection.GoTo what:=wdGoToSection, which:=wdGoToNext语句后，标题文本与事先保存的标题文本相同，就可以推定已经处理完毕（如果文档中有相邻两节的标题完全一样且并非最后两节，这个推定就是错的。希望你手上的文档没有这么奇葩。如果真碰上了这么奇葩的文档，那就用本步骤中第一个代码块的方式，每次循环中处理完一节的页眉后，判断一下当前光标所在节编号是不是与总节数相等来决定是否结束循环吧），从而终止循环。以下是效率较高的做法：

Sub 页眉中插入到相应一级目录项的链接()
'
' 此宏在Word文档中每页页眉插入返回文档目录中相应位置的超链接
' 超链接显示的文本为当前页面所属章节的标题
' 此宏顺利执行的前提：
'      1、每个章节的标题制定了“标题 1”样式
'      2、在每个章节的标题前插入了分节符
'      3、文档中插入了自动目录，运行本文第一个宏为每个一级标题目录项生成了
'   形如“con_”加数字序号的书签。
'
    Dim disText As String, i As Integer, aPara As Paragraph
    ' 变量i用于计算书签中的数字序号
    i = 1
    ' 变量disText用于记录章节标题文本内容
    disText = ""
    ' 禁止屏幕滚动以提高效率，执行文档内容插入与修改一般应当这样做
    Application.ScreenUpdating = False
    ' 将页面视图激活区域指定为主文档
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    With Selection
        ' 光标移动至文档开头
        .HomeKey unit:=wdStory
    
        Do
            ' 光标跳到下一节开头
            .GoTo what:=wdGoToSection, which:=wdGoToNext
            ' 选择下一节开头的标题段落
            .MoveDown unit:=wdParagraph, Extend:=wdExtend
            ' 判断光标所在段落的样式名称及是不是空行
            If .Paragraphs(1).Style = "标题 1" And Len(.Range.Text) > 1 Then
                ' 如果选择的文本与此前保存的标题段落文本相同，可以推定
                ' 在原地跳转，也就是说已处理完毕，终止循环。否则保存标
                ' 题段落文本
                If disText = .Range.Text Then
                    Exit Do
                Else
                    disText = .Range.Text
                End If
                With ActiveWindow.ActivePane.View
                	' 激活当前页页眉进行页眉编辑
                    .SeekView = wdSeekCurrentPageHeader
                    ' 取消将页眉链接到上一节，各节独立设置页眉
                    Selection.HeaderFooter.LinkToPrevious = False
                    ' 删除链接前一节页眉生成的页眉
                    Selection.Paragraphs(1).Range.Delete
                    ' 插入超链接，加上了tab键便于页眉的对齐处理，去掉了段尾回车
                    ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
                		SubAddress:="con_" & i, ScreenTip:="", _
                		TextToDisplay:=vbTab & Left(disText, Len(disText) - 1)
                    i = i + 1
                    ' 激活主文档视图以便将光标跳转到下一节开头
                    .SeekView = wdSeekMainDocument
                End With
            End If
        Loop
    End With
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

以下是在页眉中插入链接到目录项的超链接最简单且最不会出错的方法，还进一步对页眉进行了处理：

Sub 页眉中插入到相应目录项的链接()
    Dim aSec As Section, i As Integer, styleName As String, leadingTxt As String
    styleName = "标题 1"
    leadingTxt = "金卡斯·博尔巴"
    Application.ScreenUpdating = False
    ' 书签编号
    i = 1
    On Error Resume Next
    ' 遍历所有节
    For Each aSec In ActiveDocument.Sections
        ' 这里只在每节第一行为非空白的标题1段落小节的页眉插入链接
        If aSec.Range.Paragraphs(1).Style = styleName And _
                Len(aSec.Range.Paragraphs(1).Range.Text) > 1 Then
            ' 取消链接到上一节页眉
            aSec.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
            ' 选择当前节页眉区域
            aSec.Headers(wdHeaderFooterPrimary).Range.Select
            With Selection
                ' 键入前导文字、tab键，添加引用标题内容的域
                .TypeText Text:=leadingTxt & vbTab
                .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
                    "STYLEREF  """ & styleName & """", PreserveFormatting:=True
                ' 再次重新选择页眉，设置字体大小，插入超链接，重新设置制表位位置
                .Paragraphs(1).Range.Select
                ' 插入超链接
                ActiveDocument.Hyperlinks.Add Anchor:=.Range, Address:="", _
                    SubAddress:="con_" & i, ScreenTip:=""
                    
                .Font.Size = 10 ' 字体大小为五号
                .ParagraphFormat.TabStops.ClearAll ' 清除默认的制表位
                ' 设置右对齐制表位，A4纸左右页边距2.5cm时设置在16cm处靠近页面右边距位置
                .ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(16 _
                    ), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces
            End With
            ' 调整节编号
            i = i + 1
        End If
    Next
    Application.ScreenUpdating = True
    ' 恢复视图为页面视图
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    ActiveWindow.ActivePane.View.Type = wdPrintView    
End Sub