|
|
楼主 |
发表于 2024-2-29 11:22:19
|
显示全部楼层
我自己做了。只支持我自己的著者出版年制样式，供你们参考吧。
Sub LinkAllReference()
cursorStart = AddBookmarksToReferenceList("NE.Bib")
If cursorStart = -1 Then
MsgBox "No field with code containing '" & "NE.Bib" & "' found.", vbInformation
Exit Sub
End If
'The first field
Selection.HomeKey Unit:=wdStory
cursorStart = SelectNextField("NE.Ref")
If cursorStart >= 0 Then
cursorStart = cursorStart + 1
Do
If InStr(1, Selection.Range.Text, "；") > 0 Then Debug.Print "More than one references: "; Selection.Range.Text
If Selection.Range.Hyperlinks.Count = 0 Then dummy = AddHyperlinkToBookmark
cursorField = SelectNextField("NE.Ref")
Loop While cursorField > cursorStart And cursorField > 0
Else
MsgBox "No field with code containing '" & "NE.Ref" & "' found after the cursor position.", vbInformation
End If
End Sub
Function AddBookmarksToReferenceList(fieldName)
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
cursorStart = SelectNextField(fieldName)
' 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
' Create a regular expression object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = False
.MultiLine = True
.IgnoreCase = True
.Pattern = "^([^,\s]+)[,\s].*?(\d{4}[a-z\.-])" ' Match text until the first comma, followed by a 4-digit number and a period
End With
' Initialize counter
counter = 1
' 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
Set match = regex.Execute(para.Range.Text)
If match.Count > 0 Then
' Construct bookmark name with counter and 4-digit number
bookmarkName = match(0).SubMatches(0) & "_" & match(0).SubMatches(1) & "_" & counter
bookmarkName = Replace(bookmarkName, " ", "")
bookmarkName = Replace(bookmarkName, ".", "")
bookmarkName = Replace(bookmarkName, "-", "")
' Add a bookmark with the constructed name
If bookmarkName <> "" Then
ActiveDocument.Bookmarks.Add Name:=bookmarkName, Range:=para.Range
End If
' Increment counter
counter = counter + 1
End If
Next para
Set regex = Nothing
MsgBox "Bookmarks added successfully!", vbInformation
End Function
Function SelectNextField(fieldName)
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 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
' Optional: You can perform additional actions with the selected field
' For example, you can modify the field, extract information, etc.
' Exit the loop after the first match (selecting the next occurrence)
SelectNextField = Selection.Range.Start
Exit For
End If
End If
Next field
' Inform the user if no matching field is found
If Selection.Type = wdSelectionIP Then
SelectNextField = -1
'MsgBox "No field with code containing '" & fieldName & "' found after the cursor position.", vbInformation
End If
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
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
End If
tempText = Replace(selectedRange.Text, "（", ", ")
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = False
.MultiLine = True
.IgnoreCase = True
.Pattern = "^([^,\s]+)[,\s].*?(\d{4}[a-z]?\b)" ' Match text until the first comma, followed by a 4-digit number and a period
End With
' Get the bookmark name from user input
Set match = regex.Execute(tempText)
bookmarkName = UCase(match(0).SubMatches(0)) & "_" & match(0).SubMatches(1)
bookmarkName = Replace(bookmarkName, "-", "")
' 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
Exit Function
ElseIf matchedBookmark = "+" Then
'MsgBox "More than one bookmarks found.", vbExclamation
Debug.Print "More than one bookmarks found: " & bookmarkName
AddHyperlinkToBookmark = -1
Exit Function
End If
' Set the range of the bookmark
Set bookmarkRange = ActiveDocument.Bookmarks(matchedBookmark).Range
' Get the hyperlink address and alt text
hyperlinkAddress = "#" & matchedBookmark
hyperlinkAltText = bookmarkRange.Paragraphs(1).Range.Text ' Alt text is the entire paragraph
' Add the hyperlink
selectedRange.Hyperlinks.Add Anchor:=selectedRange, Address:=hyperlinkAddress, TextToDisplay:=selectedRange.Text, ScreenTip:=hyperlinkAltText, Target:=bookmarkRange
Set regex = Nothing
AddHyperlinkToBookmark = 1
'MsgBox "Hyperlink added successfully!", vbInformation
'Debug.Print "Hyperlink added: " & hyperlinkAddress
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) > 0 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
|
|
发表于 2024-2-28 13:11:50
发表于 2024-2-28 14:40:35
