Outlook VBA脚本移除邮件首行因富文本格式变动失效如何解决？

• 我在发送Outlook邮件前会编辑消息内容，移除属于内部流程使用的首行，以便向收件人发送干净的邮件。
• 当前脚本仅在首行格式统一时可正常运行，若首行出现颜色、斜体、粗体等格式差异，脚本就无法成功移除该行。
• 我希望实现无论首行格式如何都能正常移除该行，同时保留邮件正文其余部分的原有格式。

失效场景示例 #

需要移除的首行标准格式为 BAAR-6546543456.，若内容显示为 BAAR-6546543456. 或 BAAR-6546543456. 这类带格式的样式时，现有代码就会失效。

现有完整VBA脚本 #

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim OutMail As Object
Dim PrintMail As Object
Dim FirstLetters As String
Dim LastPos As Long
Dim sHostName As String
Dim DirectoryLine As String

On Error GoTo EndTask

Set Item = CreateObject("Outlook.Application")
Set OutMail = Item.ActiveInspector.CurrentItem

sHostName = Environ$("username")

FirstLetters = Left(OutMail.Body, 5)
LastPos = InStr(OutMail.Body, ".")

If Right(FirstLetters, 1) = "-" Then
    
    If RecordFlag = "R" Then
        Set objMsg = Application.CreateItem(olMailItem)
            With objMsg
                .Body = "Your document(s) have been dispatched on " & Format(Now(), "yyyy-mm-dd hh:mm:ss")
                .BodyFormat = olFormatHTML ' 发送HTML格式邮件
                .Display
            End With
        Set PrintMail = Item.ActiveInspector.CurrentItem
    Else
        Dispatch_remark = " Dispatched to " & OutMail.To & "; " & OutMail.CC & " on " & Format(Now(), "yyyy-mm-dd hh:mm:ss")
        OutMail.HTMLBody = OutMail.HTMLBody & Dispatch_remark
        Set PrintMail = Item.ActiveInspector.CurrentItem
    End If

    ' 内部处理逻辑，与本次问题无关
    Processing 
    
    OutMail.HTMLBody = Replace(OutMail.HTMLBody, DirectoryLine, "", , , 1)
    
    If RecordFlag = "R" Then
        objMsg.Delete
    Else
        OutMail.HTMLBody = Replace(OutMail.HTMLBody, Trim(Dispatch_remark), "", 1)
    End If

End If

Set objMsg = Nothing
Set OutMail = Nothing
Set PrintMail = Nothing
Set Item = Nothing

EndTask:

End Sub

核心失效点 #

现有脚本的问题出在Replace方法的匹配逻辑：当目标内容带格式时，HTML源码中会嵌套<em>、<strong>、<span>等格式标签，纯文本精确匹配无法命中对应内容：

OutMail.HTMLBody = Replace(OutMail.HTMLBody, DirectoryLine, "", , , 1)

If RecordFlag = "R" Then
    objMsg.Delete
Else
    OutMail.HTMLBody = Replace(OutMail.HTMLBody, Trim(Dispatch_remark), "", 1)
End If

你可以改用Outlook内置的Word编辑器接口操作邮件内容，直接通过纯文本定位目标内容后删除，全程保留剩余内容的原有格式，不需要手动处理复杂的HTML标签嵌套逻辑，修改后代码如下：

核心修改段 #

' 原有代码判定首行符合删除规则后，替换原来的Replace逻辑
Dim wordDoc As Object
Dim firstLineRange As Object
Set wordDoc = OutMail.GetInspector.WordEditor

' 定位正文第一段（即要删除的内部首行）
Set firstLineRange = wordDoc.Paragraphs(1).Range
' 二次校验避免误删
If firstLineRange.Text Like "BAAR-*.*" Then
    firstLineRange.Delete
End If

' Dispatch_remark删除逻辑也按此修改，规避格式问题
If RecordFlag <> "R" Then
    Dim allRange As Object
    Set allRange = wordDoc.Content
    With allRange.Find
        .Text = Trim(Dispatch_remark)
        .MatchWholeWord = False
        .MatchCase = False
        ' 关闭格式匹配，仅按文本内容搜索
        .Format = False
        If .Execute Then
            ' 命中后直接删除对应范围，不影响其他格式
            allRange.Delete
        End If
    End With
End If

逻辑说明 #

• Outlook的富文本编辑底层基于Word实现，调用GetInspector.WordEditor可以直接获取邮件内容的Word文档对象，无视HTML标签直接操作可见文本和格式
• 直接定位第一段内容删除，无论该段内的文本是斜体、粗体还是带自定义颜色，都可以完整删除整行
• 搜索Dispatch_remark时关闭格式匹配，即可忽略所有格式差异，仅按文本内容匹配，不会出现带格式就匹配失败的问题

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