在 MS-Word 中动态重新编码选定的超链接

Question

下面的代码难以处理现有的超链接文本。 任何见解将不胜感激。

所选要链接的文本是：A1234567

如果文本部分“A123456”被超链接，选择/范围为“A1234567”，则仅重新超链接“A123456”。

脚本必须处理的其他事情是忽略末尾的非数字，即：
A1234567/A1234568、A1234569；

不删除换行符（向上移动行）：

A1234567

A1234568

表格列中的文本如上所述。

哦，在某一阶段我会选择文本，它会插入超链接并保留现有文本。 我会按 Ctrl-Z，再做一次，效果会很好（奇怪！）。

我想我已经看太多代码了...这应该很简单！！！

Dim rng As Range
Dim id As String
Dim regex As Object
Dim matches As Object
Dim hyperlinkUrl As String
Dim i As Integer
Dim foundHyperlink As Boolean
Dim existingHyperlink As Hyperlink

' Define the regular expression to match IDs starting with A followed by 7 digits
Set regex = CreateObject("VBScript.RegExp")
regex.IgnoreCase = True
regex.Global = True
regex.Pattern = "\bA\d{7}\b" ' Matches A followed by exactly 7 digits

' Get the selection
Set rng = Selection.Range

' Check if the selected text is already a hyperlink
foundHyperlink = False
For Each existingHyperlink In ActiveDocument.Hyperlinks
    If existingHyperlink.Range = rng Then
        foundHyperlink = True
        Exit For
    End If
Next existingHyperlink

' Apply the regex pattern to find all matching IDs in the selected text
Set matches = regex.Execute(rng.Text)

' Loop through each match and create or update a hyperlink
For i = 0 To matches.Count - 1
    id = matches.Item(i).Value
    ' Create the URL with the matched ID
    hyperlinkUrl = "www.website.com/id:" & id & "@port:8643"
   
    If foundHyperlink Then
        ' If the text is already a hyperlink, update the URL and text
        existingHyperlink.Address = hyperlinkUrl
        existingHyperlink.TextToDisplay = id
    Else
        ' If no hyperlink found, create a new hyperlink
        Set rng = Selection.Range
        rng.Find.Execute FindText:=id
       
        If rng.Find.Found Then
            ' Create a new hyperlink at the found location
            ActiveDocument.Hyperlinks.Add _
                Anchor:=rng, _
                Address:=hyperlinkUrl, _
                TextToDisplay:=id
        End If
    End If
Next i

Answer 1

您可以通过 Word 的

Find

方法使用通配符：

Sub LinkUpdate()
    Dim rng As Range, ids As Collection, idRng As Range, url As String, txt As String
    
    Set rng = ActiveDocument.Range 'Selection.Range ' Get the selection
    Set ids = AllIds(rng)
    Debug.Print "Found: " & ids.Count & " ids"
    
    For Each idRng In ids
        txt = idRng.Text
        url = "http://www.website.com/id:" & txt & "@port:8643"
        
        If idRng.Hyperlinks.Count > 0 Then
            With idRng.Hyperlinks(1)
                .Address = url
                .TextToDisplay = txt
            End With
        Else
            idRng.Document.Hyperlinks.Add _
                Anchor:=idRng, Address:=url, TextToDisplay:=txt
        End If
    Next
End Sub

'Find all instances of A####### in range `rng` and return
'   as a collection
Function AllIds(rng As Range) As Collection 'of Ranges
    Dim col As Collection
    Set col = New Collection
    With rng.Find
        .MatchWildcards = True
        .MatchWholeWord = True
        .Text = "<A[0-9][0-9][0-9][0-9][0-9][0-9][0-9]>"
        Do While .Execute
            'rng.HighlightColorIndex = wdBrightGreen
            Debug.Print "Found", rng.Text, rng.Start, rng.End
            col.Add rng.Duplicate
        Loop
    End With
    Set AllIds = col
End Function