为NoteExpress论文增加参考文献原文链接

如果你的论文是用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

以上。

造了个大轮子的老狼

发表回复

您的电子邮箱地址不会被公开。 必填项已用 * 标注