最近寫論文的時候，經常需要向上或向下插入題注的交叉引用，word 自帶的介面往往需要操作多次，才能實現插入。而平時使用較多的只是交叉引用附近的題注，比如如圖1.1所示，在圖1.1中等，距離較遠的引用則可以直接複製已經存在的交叉引用項，複製的項只要保留原格式複製，仍然是存在超連結的。所以可以藉助 VBA 寫一個函式，用來在當前位置插入向上或向下距離最近指定的題注型別，然後給指定的指令碼指定快捷鍵，就可以實現一鍵插入。

首先 Word VBA中關於題注和插入交叉引用，我只找到兩個函式，分別是 GetCrossReferenceItems 和 InsertCrossReference

由於 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程式碼高亮的實現方法