Word 借助VBA一键实现插入交叉引用

最近写论文的时候，经常需要向上或向下插入题注的交叉引用，word 自带的界面往往需要操作多次，才能实现插入。而平时使用较多的只是交叉引用附近的题注，比如如图1.1所示，在图1.1中等，距离较远的引用则可以直接复制已经存在的交叉引用项，复制的项只要保留原格式复制，仍然是存在超链接的。所以可以借助 VBA 写一个函数，用来在当前位置插入向上或向下距离最近指定的题注类型，然后给指定的脚本指定快捷键，就可以实现一键插入。

首先 Word VBA中关于题注和插入交叉引用，我只找到两个函数，分别是 GetCrossReferenceItems 和 InsertCrossReference，一个是获得当前所有的特定题注，一个是插入指定的题注，其中InsertCrossReference 需要使用 GetCrossReferenceItems 来确定插入的题注所在的位置。

由于 GetCrossReferenceItems 的对象是全文，因此需要首先找到距离最近的题注所在的位置，然后取得其相应的特征值，最后与GetCrossReferenceItems返回的结果进行对比，确定其索引值后，再使用InsertCrossReference进行插入。

根据上述思路， 整体代码如下：

Public Function autoInsertReferece(crossRefName As String, direction As Integer) As Boolean
    ' 功能：自动插入最靠近当前位置的题注，需要指定向上或向下搜索
    ' 变量名:
        ' crossRefName: 题注名
        ' direction: 方向  0-> 向下搜索 其它整数->向上搜索
    ' 注意事项：
        ' 必须要文档中定义相应的标签
        ' 先找到向上或向下距离最近的标注所在的段落，获得其文本后，再确定其在所有该类题注中所处的位置
        ' 工具》引用》Microsoft VBScript Regular Expressions 5.5打勾
 
    Dim target_para As Long
    Dim flag As Boolean
    Dim flagUpdate As Boolean
    Dim rngParagraph As Range
    Dim currentParaNum As Long
    Dim endParaNum As Long
 
    target_para =
    flag = False
    flagUpdate = False
 
    ' 根据方向做不同处理, 找到距离最近的题注对象，获得其所在的段落
    currentParaNum = ActiveDocument.Range(, Selection.End).Paragraphs.Count '获得当前的段落数
 
    Set rngParagraph = ActiveDocument.Paragraphs(currentParaNum).Range
    If direction =  Then
        endParaNum = ActiveDocument.Paragraphs.Count
        rngParagraph.SetRange Start:=rngParagraph.Start, _
        End:=ActiveDocument.Paragraphs(endParaNum).Range.End
        target_para = findTargetPara(crossRefName, direction, rngParagraph)
    Else
        '以20段为周期，向上遍历，直到行首
        Dim para_step As Integer
        para_step =
        Do While currentParaNum > para_step
            currentParaNum = currentParaNum - para_step
            rngParagraph.SetRange Start:=rngParagraph.End, _
            End:=ActiveDocument.Paragraphs(currentParaNum).Range.End
            target_para = findTargetPara(crossRefName, direction, rngParagraph)
            If target_para <>  Then
                Exit Do
            End If
            '重新设置 range
            Set rngParagraph = ActiveDocument.Paragraphs(currentParaNum).Range
        Loop
        '没找到目标段落，处理到开关
        If target_para =  Then
            rngParagraph.SetRange Start:=rngParagraph.Start, _
            End:=ActiveDocument.Paragraphs().Range.End
            target_para = findTargetPara(crossRefName, direction, rngParagraph)
        End If
    End If
    '找到段落后进行相应的处理
 
    If target_para <>  Then
        ' 获取目标段落的文本
        Dim target_text As String
        ActiveDocument.Paragraphs(target_para).Range.Fields.Update  '更新目标域代码，以防出错
        target_text = ActiveDocument.Paragraphs(target_para).Range.Text
        ' 正则表达式设置
        Dim regEx, Match, Matches  '创建变量
        Set regEx = New RegExp  '创建正则表达式
        regEx.Pattern = "\s*\d+(.\d+)*"  '设置匹配字符串， 匹配 2 2.1 2.1.1等
        regEx.IgnoreCase = True  '设置是否区分大小写
        regEx.Global = True  '设置全程匹配
 
        Set Match = regEx.Execute(target_text)  '执行搜索
        target_item = Match.Item().Value  '目标题注
        allCrossRef = ActiveDocument.GetCrossReferenceItems(crossRefName)
        For I =  To UBound(allCrossRef)  '遍历所有的给定题注直至找到目标题注
            Set Match = regEx.Execute(allCrossRef(I))
            compare_item = Match.Item().Value
            If target_item = compare_item Then
                If crossRefName <> "公式" Then
                ' 非公式只引用题注
                Selection.InsertCrossReference ReferenceType:=crossRefName, ReferenceKind:= _
                    wdOnlyLabelAndNumber, ReferenceItem:=CStr(I), InsertAsHyperlink:=True, _
                    IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
                    flag = True
                Else
                    ' 公式全文引用
                    Selection.InsertCrossReference ReferenceType:=crossRefName, ReferenceKind:= _
                        wdEntireCaption, ReferenceItem:=CStr(I), InsertAsHyperlink:=True, _
                        IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
                End If
                Selection.TypeText Text:=" "  '输出一个空格
                flag = True
                Exit For
            End If
        Next
 
    End If
    autoInsertReferece = flag
End Function
 
Private Function findTargetPara(crossRefName As String, direction As Integer, rngParagraph As Range)
    '在指定的范围内查找目标段落
    '参数说明
        'direction = 0 向下搜索，找到后立即跳出，否则向上搜索，完全遍历后再确定是否找到目标项
    Dim target_para As Long
    target_para =
    For Each para In rngParagraph.Paragraphs:
        'If para.Range.Tables.Count = 0 Then  '跳过表格，以加快处理速度
            For Each oField In para.Range.Fields
                With oField
                    If .Code.Text = " SEQ " + crossRefName + " \* ARABIC \s 1 " Then
                        target_para = ActiveDocument.Range(, para.Range.End).Paragraphs.Count
                        If direction =  Then
                            Exit For
                        End If
                    End If
                End With
            Next
        If direction =  And target_para <>  Then
            Exit For
        End If
    Next
 
    findTargetPara = target_para
 
End Function
 
Sub InsertPictureCrossReferenceDown()
    autoInsertReferece "图",
End Sub
 
Sub InsertPictureCrossReferenceUp()
    autoInsertReferece "图",
End Sub
 
Sub InsertTableCrossReferenceDown()
    autoInsertReferece "表",
End Sub
 
Sub InsertTableCrossReferenceUp()
    autoInsertReferece "表",
End Sub
 
Sub InsertMathCrossReferenceDown()
 
    Selection.TypeText Text:=" "
    flag = autoInsertReferece("公式", )
    If Not flag Then
        Selection.TypeBackspace
    End If
 
End Sub
 
Sub InsertMathCrossReferenceUp()
 
    Selection.TypeText Text:=" "
    flag = autoInsertReferece("公式", )
    If Not flag Then
        Selection.TypeBackspace
    End If
 
End Sub

代码中 autoInsertReferece 为主体实现函数，由于 Word 中的 Range 遍历只能从上向下进行，而自己用索引去遍历，运行速度会非常慢。所以，当需要向上搜索目标题注时，只能以一个一个段落范围的range向前推进，如果一个范围搜索后，找到结果，就说明其为最后的结果；而向下搜索时，则可以直接把 range 设为从当前到文未，找到目标题注后，即可立即停止搜索。findTargetPara   的主要功能是在给定的范围内，找到题注所在的段落。

最后的相应 Sub 函数是具体的应用，由于我对文中的公式有特殊的处理，插入时需要引用题注和内容，其余的默认只引用题注。实际使用时，可以给相应的 Sub 设定快捷键，比如将  InsertPictureCrossReferenceDown 宏的快捷键设为 Alt + 1，然后在Word文档中按 Alt + 1 键，即可在当前位置插入距离当前位置最近的题注（向下搜索）。

宏的使用及快捷键设置参照  Onenote代码高亮的实现方法