1. 摘要
针对 Word 中 Zotero 插入参考文献时正文引用角标缺乏交叉引用功能、难以满足本科及硕士学位论文格式要求的问题，本文设计并实现了一种基于 VBA 宏的自动化处理方法。传统手动添加标签并建立交叉引用的方式操作繁琐，且在参考文献数量较多或后续需要调整文献顺序、增删文献时，维护成本较高，同时难以继续利用 Zotero 的参考文献一键更新功能。为解决上述问题，本文方法通过遍历 Word 文档中的 Zotero 引文字段，读取字段代码中的文献标题信息，并解析正文中显示的数字引用，将引用编号或编号范围与对应文献标题进行匹配；随后在参考文献列表中依据标题定位具体条目，自动建立书签，并为正文引用数字添加指向相应书签的超链接。实验结果表明，该方法能够有效实现 Zotero 正文引用与参考文献条目之间的自动跳转，在满足论文格式需求的同时，保留了 Zotero 更新参考文献的功能，具有一定的实用价值和可扩展性。
2. 前提条件
-
本代码仅做过word的实验，wps应该也可以，若存在问题请自行修改或者切换到word
-
在插入完zotero的参考文献后注意不要点击zotero与word的unlink citation
3. 使用方式
-
开启word宏的所有权限，网上有教程很简单。
-
打开word，找到宏选项，创建新宏，清空所有原来的输入我的VBA宏代码，保存。
-
在zotero插入参考文献后点击运行宏，即可看到交叉引用插入成功。
4.如果需要修改参考文献，插入后zotero刷新参考文献，再次运行宏，不需要撤回或者删除原有的交叉引用。
4. VBA代码
Option Explicit
Public Sub ZoteroLinkCitationNumeric()
Dim doc As Document
Dim bibRange As Range
Dim fld As Field
Dim titles As Collection
Dim specs As Collection
Dim bookmarkCache As Object
Dim i As Long
Dim spec As Variant
Dim targetBookmark As String
Dim linkRange As Range
Set doc = ActiveDocument
Set bibRange = GetZoteroBibliographyRange(doc)
If bibRange Is Nothing Then
MsgBox "没有找到 Zotero 自动生成的参考文献列表（ADDIN ZOTERO_BIBL）。", vbExclamation
Exit Sub
End If
Set bookmarkCache = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
SetHyperlinkStylesBlack doc
For Each fld In doc.Fields
If InStr(1, fld.Code.Text, "ADDIN ZOTERO_ITEM", vbTextCompare) > 0 Then
Set titles = ExtractTitlesFromFieldCode(fld.Code.Text)
If titles.Count > 0 Then
Set specs = BuildNumericLinkSpecs(CleanCitationText(fld.Result.Text), titles)
If specs.Count > 0 Then
RemoveHyperlinksInRange fld.Result
For i = specs.Count To 1 Step -1
spec = specs(i)
targetBookmark = EnsureBibliographyBookmark(CStr(spec(2)), doc, bibRange, bookmarkCache)
If Len(targetBookmark) > 0 Then
Set linkRange = doc.Range( _
Start:=fld.Result.Start + CLng(spec(0)) - 1, _
End:=fld.Result.Start + CLng(spec(0)) - 1 + CLng(spec(1)))
doc.Hyperlinks.Add _
Anchor:=linkRange, _
Address:="", _
SubAddress:=targetBookmark, _
ScreenTip:=CStr(spec(2)), _
TextToDisplay:=linkRange.Text
With linkRange.Font
.Color = wdColorBlack
.Underline = wdUnderlineNone
End With
End If
Next i
End If
End If
End If
Next fld
Application.ScreenUpdating = True
MsgBox "Zotero 引文超链接已处理完成。", vbInformation
End Sub
Private Sub SetHyperlinkStylesBlack(doc As Document)
On Error Resume Next
doc.Styles("Hyperlink").Font.Color = wdColorBlack
doc.Styles("Hyperlink").Font.Underline = wdUnderlineNone
doc.Styles("FollowedHyperlink").Font.Color = wdColorBlack
doc.Styles("FollowedHyperlink").Font.Underline = wdUnderlineNone
On Error GoTo 0
End Sub
Private Function GetZoteroBibliographyRange(doc As Document) As Range
Dim fld As Field
For Each fld In doc.Fields
If InStr(1, fld.Code.Text, "ADDIN ZOTERO_BIBL", vbTextCompare) > 0 Then
Set GetZoteroBibliographyRange = fld.Result.Duplicate
Exit Function
End If
Next fld
Set GetZoteroBibliographyRange = Nothing
End Function
Private Function ExtractTitlesFromFieldCode(fieldCode As String) As Collection
Dim rx As Object
Dim matches As Object
Dim m As Object
Dim result As New Collection
Dim s As String
Set rx = CreateObject("VBScript.RegExp")
rx.Global = True
rx.IgnoreCase = True
rx.Pattern = """title"":""((?:[^""\\]|\\.)*)"""
Set matches = rx.Execute(fieldCode)
For Each m In matches
s = m.SubMatches(0)
s = Replace(s, "\""","""")
s = Replace(s, "\\", "\")
result.Add s
Next m
Set ExtractTitlesFromFieldCode = result
End Function
Private Function BuildNumericLinkSpecs(citationText As String, titles As Collection) As Collection
Dim rx As Object
Dim matches As Object
Dim m As Object
Dim result As New Collection
Dim token As String
Dim compactToken As String
Dim parts() As String
Dim firstNum As String
Dim lastNum As String
Dim firstVal As Long
Dim lastVal As Long
Dim rangeCount As Long
Dim itemIndex As Long
Dim lastLocalPos As Long
Set rx = CreateObject("VBScript.RegExp")
rx.Global = True
rx.Pattern = "\d+(?:\s*[-－-----]\s*\d+)?"
Set matches = rx.Execute(citationText)
itemIndex = 1
For Each m In matches
token = m.Value
compactToken = token
compactToken = Replace(compactToken, " ", "")
compactToken = Replace(compactToken, "－", "-")
compactToken = Replace(compactToken, "--", "-")
compactToken = Replace(compactToken, "---", "-")
If InStr(compactToken, "-") > 0 Then
parts = Split(compactToken, "-")
If UBound(parts) = 1 Then
firstNum = parts(0)
lastNum = parts(1)
firstVal = CLng(firstNum)
lastVal = CLng(lastNum)
If lastVal >= firstVal Then
rangeCount = lastVal - firstVal + 1
If itemIndex <= titles.Count Then
result.Add Array(m.FirstIndex + 1, Len(firstNum), CStr(titles(itemIndex)))
End If
If itemIndex + rangeCount - 1 <= titles.Count Then
lastLocalPos = InStrRev(token, lastNum)
result.Add Array(m.FirstIndex + lastLocalPos, Len(lastNum), CStr(titles(itemIndex + rangeCount - 1)))
End If
itemIndex = itemIndex + rangeCount
End If
End If
Else
If itemIndex <= titles.Count Then
result.Add Array(m.FirstIndex + 1, Len(compactToken), CStr(titles(itemIndex)))
itemIndex = itemIndex + 1
End If
End If
Next m
Set BuildNumericLinkSpecs = result
End Function
Private Function EnsureBibliographyBookmark(ByVal title As String, _
ByVal doc As Document, _
ByVal bibRange As Range, _
ByVal cache As Object) As String
Dim searchRange As Range
Dim paraRange As Range
Dim bookmarkName As String
Dim idx As Long
If cache.Exists(title) Then
EnsureBibliographyBookmark = CStr(cache(title))
Exit Function
End If
Set searchRange = bibRange.Duplicate
With searchRange.Find
.ClearFormatting
.Text = Left(title, 255)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
If searchRange.Find.Execute Then
Set paraRange = searchRange.Paragraphs(1).Range
idx = cache.Count + 1
bookmarkName = MakeSafeBookmarkName(title, idx)
Do While doc.Bookmarks.Exists(bookmarkName)
idx = idx + 1
bookmarkName = MakeSafeBookmarkName(title, idx)
Loop
doc.Bookmarks.Add Name:=bookmarkName, Range:=paraRange
cache.Add title, bookmarkName
EnsureBibliographyBookmark = bookmarkName
Else
cache.Add title, ""
EnsureBibliographyBookmark = ""
End If
End Function
Private Function MakeSafeBookmarkName(ByVal title As String, ByVal idx As Long) As String
Dim i As Long
Dim ch As String
Dim s As String
For i = 1 To Len(title)
ch = Mid$(title, i, 1)
If ch Like "[A-Za-z0-9]" Then
s = s & ch
Else
s = s & "_"
End If
Next i
s = "ZRef_" & Left$(s, 30) & "_" & CStr(idx)
MakeSafeBookmarkName = s
End Function
Private Sub RemoveHyperlinksInRange(rng As Range)
Dim i As Long
On Error Resume Next
For i = rng.Hyperlinks.Count To 1 Step -1
rng.Hyperlinks(i).Delete
Next i
On Error GoTo 0
End Sub
Private Function CleanCitationText(ByVal s As String) As String
s = Replace(s, vbCr, "")
s = Replace(s, vbLf, "")
s = Replace(s, ChrW(160), " ")
s = Replace(s, "，", ",")
s = Replace(s, "（", "(")
s = Replace(s, "）", ")")
CleanCitationText = Trim$(s)
End Function