如果你的论文是用NoteExpress组织参考文献，而且使用了著者出版年制，那么你有福了。这段VBA代码可以给所有带DOI或网址的参考文献增加原文链接，即使生成PDF后也可以点击直接打开浏览器，跳转到提供原文的网站。鼠标悬停时，还可以显示整条题录信息，方便阅读。点击这里下载PDF演示页
使用Adobe Acrobat或Adobe Reader可以获得最佳效果，如图所示：
用法：打开VBA编辑器，将代码复制粘贴过去，运行LinkAllReference，即可。但要注意，生成PDF文件时要按照这个步骤：点击“文件”，“另存为”，在弹出的对话框中，把“保存类型”选为pdf，按下图设置：
进阶的用法是，使用我提供的NoteExpress样式，效果更佳。对于一些没有DOI的文献，这个样式可以把NoteExpress里存储的链接放在参考文献题录里，用$$……$$标记起来，实现同样的点击效果。而且本代码在添加链接之后，会自动把多余的链接隐藏，不影响PDF和打印版的外观。点击这里下载样式
VBA代码如下，Word 2021测试通过，WPS可用。
Sub LinkAllReference()
cursorStart = AddBookmarksToReferenceList("NE.Bib", 1)
Selection.HomeKey Unit:=wdStory
If cursorStart = -1 Then
MsgBox "No field with code containing '" & "NE.Bib" & "' found.", vbInformation
Exit Sub
End If
'The first field
startFieldNumber = SelectNextField("NE.Ref", 1)
cursorStart = Selection.Range.Start
If cursorStart >= 0 Then
cursorStart = cursorStart + 1
Do
If InStr(1, Selection.Text, "；") > 0 Then
'Debug.Print "More than one references: "; Selection.Text
originalLen = Len(Selection.Text)
originalStr = Selection.Text
countRef = Len(originalStr) - Len(Replace(originalStr, "；", "")) + 1
Selection.MoveEnd Unit:=wdCharacter, Count:=-originalLen
For i = 1 To countRef - 1
Selection.MoveStart Unit:=wdCharacter, Count:=1
Selection.MoveEndUntil Cset:="；", Count:=wdForward
If Selection.Hyperlinks.Count = 0 Then dummy = AddHyperlinkToBookmark
Next i
Selection.MoveStart Unit:=wdCharacter, Count:=1
Selection.MoveEndUntil Cset:="）", Count:=wdForward
If Selection.Hyperlinks.Count = 0 Then dummy = AddHyperlinkToBookmark
Else
If Selection.Hyperlinks.Count = 0 Then dummy = AddHyperlinkToBookmark
End If
If startFieldNumber > 0 Then startFieldNumber = SelectNextField("NE.Ref", startFieldNumber)
cursorField = Selection.Range.Start
DoEvents
Loop While cursorField > cursorStart And cursorField > 0 And startFieldNumber > 0
Else
MsgBox "No field with code containing '" & "NE.Ref" & "' found after the cursor position.", vbInformation
End If
dummy = hideRefHyperlink("NE.Bib", 1)
MsgBox "Complete.", vbExclamation
End Sub
Function AddBookmarksToReferenceList(fieldName, startFieldNumber)
Dim selectedRange As Range
Dim para As Paragraph
Dim bookmarkName As String
Dim regex As Object
Dim match As Object
Dim counter As Integer
Selection.HomeKey Unit:=wdStory
For Each field In ActiveDocument.Fields
' Check if the field code contains the specified string
If InStr(1, field.Code.Text, fieldName, vbTextCompare) > 0 Then
' Check if the field is after the current cursor position
If field.Code.Start > currentPosition Then
' Select the field
field.Select
' Exit the loop after the first match (selecting the next occurrence)
Exit For
End If
End If
Next field
' Show hidden font(hyperlinks)
Selection.Font.Hidden = False
cursorStart = Selection.Range.Start
' Check if text is selected
If Selection.Type = wdSelectionIP Or cursorStart = -1 Then
MsgBox "Field NE.Lib not found.", vbExclamation
Exit Function
End If
' Set the selected range
Set selectedRange = Selection.Range
' Initialize counter
counter = 0
' Loop through each paragraph in the selected range
For Each para In selectedRange.Paragraphs
' Get the text until the first comma and 4-digit number
bookmarkName = getBookmarkName(para.Range.Text)
If bookmarkName <> "" Then
counter = counter + 1
ActiveDocument.Bookmarks.Add Name:=bookmarkName, Range:=para.Range
End If
Next para
Set regex = Nothing
Debug.Print counter & " Bookmarks added successfully!"
End Function
Function AddHyperlinkToBookmark()
Dim selectedRange As Range
Dim bookmarkName As String
Dim bookmarkRange As Range
Dim hyperlinkAddress As String
Dim hyperlinkAltText As String
Dim match As Object
' Check if text is selected
If Selection.Type = wdSelectionIP Then
'MsgBox "Please select some text before running this macro.", vbExclamation
Debug.Print "Please select some text before running this macro."
AddHyperlinkToBookmark = -1
Exit Function
End If
' Set the selected range
Set selectedRange = Selection.Range
If Left(selectedRange.Text, 1) = "（" Then
selectedRange.MoveStart Unit:=wdCharacter, Count:=1
If Right(selectedRange.Text, 1) = "）" Then selectedRange.MoveEnd Unit:=wdCharacter, Count:=-1
Selection.Collapse
Selection.Start = selectedRange.Start
Selection.End = selectedRange.End
Else
selectedRange.MoveStart Unit:=wdCharacter, Count:=1
selectedRange.Start = selectedRange.Start - 1
Selection.Collapse
Selection.Start = selectedRange.Start
If Right(selectedRange.Text, 1) = "）" Then
Selection.End = selectedRange.End - 1
Else
Selection.End = selectedRange.End
End If
End If
temptext = Replace(Selection.Text, "（", ", ")
temptext = Replace(temptext, "）", "")
bookmarkName = getBookmarkName(temptext)
' Check if the bookmark exists
matchedBookmark = FindStringInBookmarks(bookmarkName)
If matchedBookmark = "0" Then
'MsgBox "Bookmark not found.", vbExclamation
Debug.Print "Bookmark not found: " & bookmarkName
AddHyperlinkToBookmark = -1
Selection.Collapse Direction:=wdCollapseEnd
Exit Function
ElseIf matchedBookmark = "+" Then
'MsgBox "More than one bookmarks found.", vbExclamation
Debug.Print "Multi bookmarks: " & bookmarkName
AddHyperlinkToBookmark = -1
Selection.Collapse Direction:=wdCollapseEnd
Exit Function
End If
' Set the range of the bookmark
Set bookmarkRange = ActiveDocument.Bookmarks(matchedBookmark).Range
' Get the hyperlink address and alt text
hyperlinkAltText = bookmarkRange.Paragraphs(1).Range.Text ' Alt text is the entire paragraph
hyperlinkAltText = Replace(hyperlinkAltText, ChrW(8204), "") 'Remove zero-width space
hyperlinkAddress = hyperlinkAltText
If InStr(1, bookmarkRange.Paragraphs(1).Range.Text, "$$") > 0 Then hyperlinkAltText = Left(hyperlinkAltText, InStr(1, hyperlinkAltText, "$$") - 1)
hyperlinkAltText = Replace(Replace(hyperlinkAltText, "“", """"), "”", """") 'Replace widechar quote marks to avoid word bug, otherwise the link would be broken
If InStr(1, hyperlinkAddress, "DOI: ") > 0 Then
hyperlinkAddress = "https://doi.org/" & MidBetween(1, hyperlinkAddress, "DOI: ", ".$$")
If Right(hyperlinkAddress, 1) = "." Then hyperlinkAddress = Left(hyperlinkAddress, Len(hyperlinkAddress) - 1)
ElseIf InStr(1, hyperlinkAddress, "/OL]") > 0 Then
hyperlinkAddress = MidBetween(1, hyperlinkAddress, "/OL]. ", "." & vbCrLf)
If Right(hyperlinkAddress, 1) = "." Then hyperlinkAddress = Left(hyperlinkAddress, Len(hyperlinkAddress) - 1)
ElseIf InStr(1, hyperlinkAddress, "$$") > 0 Then
hyperlinkAddress = MidBetween(1, hyperlinkAddress, "$$", "$$")
Else
hyperlinkAddress = "#" & matchedBookmark
End If
' Add the hyperlink
If inOneLine() Then
selectedRange.Hyperlinks.Add Anchor:=selectedRange, Address:=hyperlinkAddress, ScreenTip:=hyperlinkAltText
Else
originalStart = Selection.Start
'originalEnd = Selection.End
originalLen = Len(Selection.Text)
Selection.Collapse Direction:=wdCollapseStart
Selection.EndOf Unit:=wdLine, Extend:=wdExtend
Set selectedRange = Selection.Range
firstLen = Len(selectedRange.Text)
selectedRange.Hyperlinks.Add Anchor:=selectedRange, Address:=hyperlinkAddress, ScreenTip:=hyperlinkAltText
newStart = selectedRange.End + 1
Selection.Collapse
Selection.Start = newStart
Selection.End = newStart + originalLen - firstLen
Set selectedRange = Selection.Range
If selectedRange.Text <> "" Then selectedRange.Hyperlinks.Add Anchor:=selectedRange, Address:=hyperlinkAddress, ScreenTip:=hyperlinkAltText
End If
Set regex = Nothing
AddHyperlinkToBookmark = 1
'MsgBox "Hyperlink added successfully!", vbInformation
'Debug.Print "Hyperlink added: " & hyperlinkAddress
End Function
Function hideRefHyperlink(fieldName, startFieldNumber)
Dim selectedRange As Range
Dim para As Paragraph
Dim bookmarkRange As Range
Selection.HomeKey Unit:=wdStory
For Each field In ActiveDocument.Fields
' Check if the field code contains the specified string
If InStr(1, field.Code.Text, fieldName, vbTextCompare) > 0 Then
' Check if the field is after the current cursor position
If field.Code.Start > currentPosition Then
' Select the field
field.Select
' Exit the loop after the first match (selecting the next occurrence)
Exit For
End If
End If
Next field
cursorStart = Selection.Range.Start
' Check if text is selected
If Selection.Type = wdSelectionIP Or cursorStart = -1 Then
MsgBox "Field NE.Lib not found.", vbExclamation
Exit Function
End If
Set selectedRange = Selection.Range
Set temprange = Selection.Range
' Loop through each paragraph in the selected range
For Each para In selectedRange.Paragraphs
If Len(para.Range.Text) > 1 Then
' Set the selected range
Set temprange = para.Range
temprange.MoveEnd Unit:=wdCharacter, Count:=-1
Selection.Collapse
Selection.Start = temprange.Start
Selection.End = temprange.End
If Selection.Paragraphs.Count > 1 Then
Set temp = Selection.Paragraphs(2).Range
Selection.Collapse
temp.Select
End If
Set bookmarkRange = para.Range
' Get the hyperlink address and alt text
temptext = bookmarkRange.Paragraphs(1).Range.Text ' Alt text is the entire paragraph
temptext = Replace(temptext, ChrW(8204), "") 'Remove zero-width space
If InStr(1, temptext, "DOI: ") > 0 Then
hyperlinkAddress = "https://doi.org/" & MidBetween(1, temptext, "DOI: ", ".$$")
If Right(hyperlinkAddress, 1) = "." Then hyperlinkAddress = Left(hyperlinkAddress, Len(hyperlinkAddress) - 1)
ElseIf InStr(1, temptext, "/OL]") > 0 Then
hyperlinkAddress = MidBetween(1, temptext, "/OL]. ", "." & vbCrLf)
If Right(hyperlinkAddress, 1) = "." Then hyperlinkAddress = Left(hyperlinkAddress, Len(hyperlinkAddress) - 1)
ElseIf InStr(1, temptext, "$$") > 0 Then
hyperlinkAddress = MidBetween(1, temptext, "$$", "$$")
Else
hyperlinkAddress = "#"
If Len(temptext) > 1 Then Debug.Print "No url for: " & Replace(temptext, vbCr, "")
End If
' Add the hyperlink
If hyperlinkAddress <> "#" Then
If Selection.Hyperlinks.Count = 0 Then Selection.Range.Hyperlinks.Add Anchor:=Selection.Range, Address:=hyperlinkAddress
End If
'Hide the temp hyperlink in bookmark range
If InStr(1, bookmarkRange.Text, "$$") > 0 Then
bookmarkRange.MoveStartUntil "$$"
bookmarkRange.MoveEnd wdCharacter, -1
bookmarkRange.Select
bookmarkRange.Font.Hidden = True
End If
End If
'Selection.Range.MoveStart Unit:=wdCharacter, Count:=1
Next para
Debug.Print "Hyperlink in Reference successfully hidden!"
End Function
Function SelectNextField(fieldName, startFieldNumber)
Dim field As field
Dim currentPosition As Long
SelectNextField = -1
' Get the current cursor position
currentPosition = Selection.Range.Start + 1
' Iterate through all fields in the document
For i = startFieldNumber To ActiveDocument.Fields.Count
Set field = ActiveDocument.Fields(i)
' Check if the field code contains the specified string
If InStr(1, field.Code.Text, fieldName, vbTextCompare) > 0 Then
' Check if the field is after the current cursor position
If field.Code.Start > currentPosition Then
' Select the field
field.Select
' Exit the loop after the first match (selecting the next occurrence)
SelectNextField = i
Set field = Nothing
Exit For
End If
End If
Next i
' Inform the user if no matching field is found
If Selection.Type = wdSelectionIP Then
SelectNextField = -1
Set field = Nothing
'MsgBox "No field with code containing '" & fieldName & "' found after the cursor position.", vbInformation
End If
End Function
Function FindStringInBookmarks(searchString As String) As String
Dim bookmark As bookmark
counter = 0
' Loop through all bookmarks in the document
For Each bookmark In ActiveDocument.Bookmarks
' Check if the search string is found in the bookmark's range
If InStr(1, bookmark.Name, searchString, vbTextCompare) = 1 Then
' Return the name of the first matching bookmark
FindStringInBookmarks = bookmark.Name
counter = counter + 1
End If
Next bookmark
' No match or more than one matches found
If counter = 0 Then
FindStringInBookmarks = "0"
ElseIf counter > 1 Then
FindStringInBookmarks = "+"
End If
End Function
Function inOneLine()
' Check if the selection range is within one line
With Selection.Range
originalEnd = Selection.Range.End
.Collapse Direction:=wdCollapseStart
t1 = .Information(wdFirstCharacterLineNumber)
.Start = originalEnd
t2 = .Information(wdFirstCharacterLineNumber)
inOneLine = (t1 = t2)
End With
End Function
Function MidBetween(nCursor, strText, strStart, strEnd)
Dim nStart, nEnd
If InStr(nCursor, strText, strStart) = 0 Then
MidBetween = ""
Else
nStart = InStr(nCursor, strText, strStart) + Len(strStart)
If InStr(nCursor, strText, strEnd) = 0 Then
nEnd = Len(strText)
Else
nEnd = InStr(nStart, strText, strEnd)
End If
MidBetween = Mid(strText, nStart, nEnd - nStart)
End If
End Function
Function getBookmarkName(strRef)
On Error GoTo errhandler
If strRef = "" Or InStr(1, strRef, ",") = 0 Then Exit Function
' Create a regular expression object
Set regex = CreateObject("VBScript.RegExp")
regex.Pattern = "(.*?)(\d{4}[a-z\.-])" ' Match text until the first comma, followed by a 4-digit number and a period
tmp = Replace(strRef, " and ", ", ") & "."
tmp = regex.Execute(tmp)(0)
arr = Split(tmp, ", ")
For i = 0 To UBound(arr)
If InStr(1, arr(i), " ") Then
getBookmarkName = getBookmarkName & MidBetween(1, arr(i), "", " ") & "_"
Else
getBookmarkName = getBookmarkName & arr(i) & "_"
End If
Next i
getBookmarkName = Mid(getBookmarkName, 1, Len(getBookmarkName) - 1)
getBookmarkName = Replace(getBookmarkName, ".", "")
getBookmarkName = Replace(getBookmarkName, "(", "")
getBookmarkName = Replace(getBookmarkName, "-", "")
getBookmarkName = UCase(getBookmarkName)
If Right(getBookmarkName, 1) = "_" Then getBookmarkName = Mid(getBookmarkName, 1, Len(getBookmarkName) - 1)
Exit Function
errhandler:
Debug.Print Err.Description
getBookmarkName = ""
End Function
以上。
造了个大轮子的老狼