Word 借助VBA一键实现插入交叉引用 Onenote代码高亮的实现方法

最近写论文的时候，经常需要向上或向下插入题注的交叉引用，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 = 0
    flag = False
    flagUpdate = False
    
    ' 根据方向做不同处理, 找到距离最近的题注对象，获得其所在的段落
    currentParaNum = ActiveDocument.Range(0, Selection.End).Paragraphs.Count '获得当前的段落数
    
    Set rngParagraph = ActiveDocument.Paragraphs(currentParaNum).Range
    If direction = 0 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 = 20
        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 <> 0 Then
                Exit Do
            End If
            '重新设置 range
            Set rngParagraph = ActiveDocument.Paragraphs(currentParaNum).Range
        Loop
        '没找到目标段落，处理到开关
        If target_para = 0 Then
            rngParagraph.SetRange Start:=rngParagraph.Start, _
            End:=ActiveDocument.Paragraphs(0).Range.End
            target_para = findTargetPara(crossRefName, direction, rngParagraph)
        End If
    End If
    '找到段落后进行相应的处理

    If target_para <> 0 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(0).Value  '目标题注
        allCrossRef = ActiveDocument.GetCrossReferenceItems(crossRefName)
        For I = 1 To UBound(allCrossRef)  '遍历所有的给定题注直至找到目标题注
            Set Match = regEx.Execute(allCrossRef(I))
            compare_item = Match.Item(0).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 = 0
    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(0, para.Range.End).Paragraphs.Count
                        If direction = 0 Then
                            Exit For
                        End If
                    End If
                End With
            Next
        If direction = 0 And target_para <> 0 Then
            Exit For
        End If
    Next
    
    findTargetPara = target_para

End Function


Sub InsertPictureCrossReferenceDown()
    autoInsertReferece "图", 0
End Sub


Sub InsertPictureCrossReferenceUp()
    autoInsertReferece "图", 1
End Sub


Sub InsertTableCrossReferenceDown()
    autoInsertReferece "表", 0
End Sub


Sub InsertTableCrossReferenceUp()
    autoInsertReferece "表", 1
End Sub


Sub InsertMathCrossReferenceDown()
    
    Selection.TypeText Text:=" "
    flag = autoInsertReferece("公式", 0)
    If Not flag Then
        Selection.TypeBackspace
    End If
    
End Sub


Sub InsertMathCrossReferenceUp()
    
    Selection.TypeText Text:=" "
    flag = autoInsertReferece("公式", 1)
    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代码高亮的实现方法