Outlook富文本邮件批量将选中URL转为带序号显示文本的超链接

针对Outlook撰写Rich Text格式邮件时的需求：

• 将选中的多个以http开头、带文件扩展名（如.pdf/.doc）的文本批量转为超链接
• 超链接显示文本统一改为「Hyperlink+递增序号」（例如Hyperlink1、Hyperlink2）
• 支持处理从Excel粘贴到邮件中自动生成的表格内容

修改后的VBA代码 #

Sub BatchHyperlinkWithIncrementalNumber()
    Dim olInspector As Outlook.Inspector
    Dim wDoc As Word.Document
    Dim rngSel As Word.Selection
    Dim regEx As Object
    Dim linkCount As Integer
    Dim tbl As Word.Table
    Dim cell As Word.Cell
    
    ' 初始化正则，匹配http/https开头、带文件扩展名的链接
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "http[s]?://.*?\.[a-zA-Z0-9]{2,4}"
    regEx.Global = True ' 开启全局匹配
    
    Set olInspector = Application.ActiveInspector
    ' 检查编辑器为Word类型（Rich Text依赖Word引擎）
    If olInspector.EditorType = olEditorWord Then
        Set wDoc = olInspector.WordEditor
        Set rngSel = wDoc.Windows(1).Selection
        linkCount = 0
        
        ' 处理选中区域内的表格
        If rngSel.Tables.Count > 0 Then
            For Each tbl In rngSel.Tables
                For Each cell In tbl.Range.Cells
                    Dim rngCell As Word.Range
                    Set rngCell = cell.Range
                    rngCell.MoveEnd wdCharacter, -1 ' 移除单元格末尾的段落标记
                    ProcessMatches rngCell, regEx, linkCount, wDoc
                Next cell
            Next tbl
        Else
            ' 处理普通选中文本
            ProcessMatches rngSel.Range, regEx, linkCount, wDoc
        End If
    End If
    
    ' 释放对象
    Set regEx = Nothing
    Set rngSel = Nothing
    Set wDoc = Nothing
    Set olInspector = Nothing
End Sub

' 辅助过程：处理指定范围内的匹配链接，添加带序号的超链接
Private Sub ProcessMatches(rng As Word.Range, regEx As Object, ByRef count As Integer, wDoc As Word.Document)
    Dim matches As Object
    Dim match As Object
    
    Set matches = regEx.Execute(rng.Text)
    ' 反向遍历，避免修改文本后位置偏移
    For i = matches.Count - 1 To 0 Step -1
        Set match = matches(i)
        Dim rngMatch As Word.Range
        Set rngMatch = rng.Duplicate
        rngMatch.Start = rng.Start + match.FirstIndex
        rngMatch.End = rngMatch.Start + match.Length
        
        ' 跳过已转为超链接的文本
        If rngMatch.Hyperlinks.Count = 0 Then
            count = count + 1
            ' 添加超链接，设置显示文本
            wDoc.Hyperlinks.Add _
                Anchor:=rngMatch, _
                Address:=match.Value, _
                TextToDisplay:="Hyperlink" & count
        End If
    Next i
End Sub

代码关键说明 #

• 精准匹配：用正则表达式锁定http/https开头、带合法文件扩展名的文本，避免误处理其他内容
• 表格适配：遍历选中区域内的所有表格单元格，处理Excel粘贴过来的表格内容
• 位置防偏移：反向遍历匹配结果，解决修改文本后后续匹配位置错乱的问题
• 序号递增：通过linkCount累计处理数量，保证超链接显示文本的序号连续
• 重复处理防护：检查文本是否已为超链接，避免重复操作

内容的提问来源于stack exchange，提问作者Peace