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 = 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代碼高亮的實現方法