word宏代码之将参考文献超链接到文本

Public Sub 创建参考文献链接()
    On Error GoTo CleanUp
    Application.ScreenUpdating = False
    
    Dim refCount As Long, linkCount As Long
    refCount = 0
    linkCount = 0
    
    ' 1. 智能定位参考文献起始位置
    Dim refStartPosition As Long
    refStartPosition = FindReferenceSectionStart()
    
    If refStartPosition = 0 Then
        MsgBox "未找到REFERENCES或参考文献章节，请检查文档结构。", vbExclamation, "提示"
        Exit Sub
    End If
    
    ' 2. 在参考文献区域创建书签
    Application.StatusBar = "正在处理参考文献..."
    Dim i As Long
    For i = 1 To ActiveDocument.paragraphs.count
        Dim para As Paragraph
        Set para = ActiveDocument.paragraphs(i)  ' 修正：这里是关键！
        
        ' 只处理REFERENCES章节后的段落
        If para.Range.Start >= refStartPosition Then
            Dim txt As String
            txt = Trim(para.Range.text)
            
            ' 跳过章节标题行
            If IsReferenceSectionTitle(txt) Then
                GoTo NextPara
            End If
            
            ' 检查是否以数字开头（参考文献条目）
            If IsReferenceItem(txt) Then
                Dim refNum As String
                refNum = ExtractReferenceNumber(txt)
                
                If refNum <> "" Then
                    ' 创建书签
                    On Error Resume Next
                    ActiveDocument.Bookmarks.Add "Ref_" & refNum, para.Range
                    On Error GoTo 0
                    refCount = refCount + 1
                    
                    ' 标记已处理的参考文献（可选）
                    para.Range.HighlightColorIndex = wdYellow
                End If
            End If
        End If
NextPara:
    Next i
    
    ' 3. 在正文中创建引用链接
    Application.StatusBar = "正在创建引用链接..."
    linkCount = CreateCitationLinksInBody(refStartPosition)
    
CleanUp:
    Application.ScreenUpdating = True
    Application.StatusBar = False
    
    If linkCount > 0 Then
        MsgBox "成功创建 " & refCount & " 个参考文献书签" & vbCrLf & _
               "成功创建 " & linkCount & " 个引用链接", vbInformation, "完成"
    Else
        MsgBox "处理完成，但未找到可用的引用链接。", vbExclamation, "提示"
    End If
End Sub

' =================================================================
' 核心功能函数
' =================================================================

' 查找REFERENCES章节起始位置
Private Function FindReferenceSectionStart() As Long
    Dim rng As Range
    Set rng = ActiveDocument.content
    
    ' 可能的参考文献标题关键词
    Dim titles(1 To 6) As String
    titles(1) = "REFERENCES"
    titles(2) = "Reference"
    titles(3) = "参考文献"
    titles(4) = "REFERENCE"
    titles(5) = "BIBLIOGRAPHY"
    titles(6) = "Bibliography"
    
    Dim i As Integer
    For i = 1 To UBound(titles)
        With rng.Find
            .ClearFormatting
            .text = titles(i)
            .Forward = True
            .Wrap = wdFindStop
            .MatchCase = False
            .MatchWholeWord = True
            
            If .Execute Then
                ' 返回标题下一个段落的起始位置
                FindReferenceSectionStart = rng.paragraphs(1).Next.Range.Start
                Exit Function
            End If
        End With
    Next i
    
    ' 如果没找到标准标题，尝试查找文档末尾的编号段落
    FindReferenceSectionStart = FindReferenceByFormat()
End Function

' 通过格式查找参考文献区域
Private Function FindReferenceByFormat() As Long
    Dim i As Long
    For i = ActiveDocument.paragraphs.count To 1 Step -1
        Dim txt As String
        txt = Trim(ActiveDocument.paragraphs(i).Range.text)
        
        ' 如果找到以"1."开头的段落，且靠近文档末尾
        If IsReferenceItem(txt) And i > ActiveDocument.paragraphs.count * 0.7 Then
            ' 向前查找参考文献起始位置
            Dim j As Long
            For j = i - 1 To 1 Step -1
                Dim prevTxt As String
                prevTxt = Trim(ActiveDocument.paragraphs(j).Range.text)
                
                ' 如果前一段落是标题或空行，则认为这里是参考文献开始
                If Len(prevTxt) = 0 Or IsReferenceSectionTitle(prevTxt) Then
                    FindReferenceByFormat = ActiveDocument.paragraphs(j + 1).Range.Start
                    Exit Function
                End If
            Next j
        End If
    Next i
    
    FindReferenceByFormat = 0
End Function

' 判断是否为参考文献条目
Private Function IsReferenceItem(text As String) As Boolean
    If Len(text) < 2 Then
        IsReferenceItem = False
        Exit Function
    End If
    
    ' 检查是否以数字开头
    If text Like "[0-9]*" Then
        Dim numPart As String
        numPart = ""
        Dim i As Long
        For i = 1 To Len(text)
            Dim ch As String
            ch = Mid(text, i, 1)
            If ch >= "0" And ch <= "9" Then
                numPart = numPart & ch
            Else
                Exit For
            End If
        Next i
        
        If numPart <> "" Then
            Dim nextChar As String
            If i <= Len(text) Then
                nextChar = Mid(text, i, 1)
                IsReferenceItem = (nextChar = "." Or nextChar = " " Or nextChar = "]")
            Else
                IsReferenceItem = True
            End If
        End If
    Else
        IsReferenceItem = False
    End If
End Function

' 判断是否为参考文献章节标题
Private Function IsReferenceSectionTitle(text As String) As Boolean
    Dim titles(1 To 6) As String
    titles(1) = "REFERENCES"
    titles(2) = "Reference"
    titles(3) = "参考文献"
    titles(4) = "REFERENCE"
    titles(5) = "BIBLIOGRAPHY"
    titles(6) = "Bibliography"
    
    Dim i As Integer
    For i = 1 To UBound(titles)
        If UCase(Trim(text)) = UCase(titles(i)) Then
            IsReferenceSectionTitle = True
            Exit Function
        End If
    Next i
    
    IsReferenceSectionTitle = False
End Function

' 提取参考文献编号
Private Function ExtractReferenceNumber(text As String) As String
    Dim i As Long
    Dim result As String
    result = ""
    
    For i = 1 To Len(text)
        Dim ch As String
        ch = Mid(text, i, 1)
        If ch >= "0" And ch <= "9" Then
            result = result & ch
        ElseIf ch = "." Or ch = " " Or ch = "]" Then
            If result <> "" Then
                Exit For
            End If
        Else
            If result <> "" Then
                Exit For
            End If
        End If
    Next i
    
    ExtractReferenceNumber = result
End Function

' 在正文中创建引用链接
Private Function CreateCitationLinksInBody(refStartPosition As Long) As Long
    Dim linkCount As Long
    linkCount = 0
    Dim rng As Range
    
    ' 查找所有方括号格式的引用
    Set rng = ActiveDocument.content
    rng.End = refStartPosition - 100
    
    With rng.Find
        .ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        .Forward = True
        .Wrap = wdFindStop
        
        Do While .Execute
            If rng.Start < refStartPosition Then
                Dim refText As String
                refText = rng.text
                
                ' 检查是否包含数字
                If ContainsNumbers(refText) Then
                    ' 提取第一个数字
                    Dim refNum As String
                    refNum = ExtractFirstRefNumberUniversal(refText)
                    
                    If refNum <> "" Then
                        If BookmarkExists("Ref_" & refNum) Then
                            ' 只处理[]内部的内容
                            Dim insideText As String
                            insideText = Mid(refText, 2, Len(refText) - 2)  ' 去掉"["和"]"
                            
                            If Len(insideText) > 0 Then
                                ' 创建[]内部内容的超链接
                                Dim insideRange As Range
                                Set insideRange = ActiveDocument.Range(rng.Start + 1, rng.End - 1)
                                
                                ' 检查内部范围是否已经有超链接
                                If insideRange.Hyperlinks.count = 0 Then
                                    ' 创建超链接
                                    ActiveDocument.Hyperlinks.Add _
                                        Anchor:=insideRange, _
                                        Address:="", _
                                        SubAddress:="Ref_" & refNum, _
                                        TextToDisplay:=insideText
                                    
                                    ' 只设置内部内容的颜色
                                    insideRange.Font.Underline = wdUnderlineNone
                                    insideRange.Font.color = RGB(0, 51, 153)  ' 蓝色
                                    
                                    ' 恢复方括号的颜色
                                    Dim leftBracket As Range, rightBracket As Range
                                    Set leftBracket = ActiveDocument.Range(rng.Start, rng.Start + 1)
                                    Set rightBracket = ActiveDocument.Range(rng.End - 1, rng.End)
                                    
                                    leftBracket.Font.color = wdColorAutomatic
                                    rightBracket.Font.color = wdColorAutomatic
                                    
                                    linkCount = linkCount + 1
                                    
                                    ' 更新进度
                                    If linkCount Mod 5 = 0 Then
                                        Application.StatusBar = "已创建 " & linkCount & " 个引用链接..."
                                        DoEvents
                                    End If
                                End If
                            End If
                        Else
                            ' 书签不存在，标记整个[]内容为红色
                            Dim insideRangeRed As Range
                            Set insideRangeRed = ActiveDocument.Range(rng.Start + 1, rng.End - 1)
                            insideRangeRed.Font.color = RGB(255, 0, 0)
                        End If
                    End If
                End If
            End If
            
            rng.Collapse wdCollapseEnd
        Loop
    End With
    
    CreateCitationLinksInBody = linkCount
End Function

' 检查字符串是否包含数字
Private Function ContainsNumbers(text As String) As Boolean
    Dim i As Long
    For i = 1 To Len(text)
        Dim ch As String
        ch = Mid(text, i, 1)
        If ch >= "0" And ch <= "9" Then
            ContainsNumbers = True
            Exit Function
        End If
    Next i
    ContainsNumbers = False
End Function

' 通用提取第一个引用编号函数
Private Function ExtractFirstRefNumberUniversal(refText As String) As String
    Dim i As Long
    Dim result As String
    result = ""
    
    ' 从第二个字符开始（跳过"["）
    For i = 2 To Len(refText)
        Dim ch As String
        ch = Mid(refText, i, 1)
        
        If ch >= "0" And ch <= "9" Then
            result = result & ch
        ElseIf ch = "-" Or ch = "–" Or ch = "," Or ch = "]" Then
            Exit For
        Else
            Exit For
        End If
    Next i
    
    ExtractFirstRefNumberUniversal = result
End Function

' 辅助函数：检查书签是否存在
Private Function BookmarkExists(name As String) As Boolean
    On Error Resume Next
    BookmarkExists = (ActiveDocument.Bookmarks(name).name = name)
    On Error GoTo 0
End Function