Excel VBA发送带签名Outlook邮件时.HTMLBody行报错求助

这个报错是两个问题叠加导致的：

• 执行.Display后，Outlook默认签名是异步加载的，代码立刻读取.HTMLBody时，签名还没渲染完成，拿到的是空值或残缺HTML片段，赋值直接触发对象定义错误
• 原代码里RangetoHTML返回的是带<html>/<head>/<body>全套标签的完整独立HTML文档，直接和邮件HTMLBody拼接会出现标签嵌套非法的问题。旧版Outlook HTML校验宽松可以正常运行，近期版本更新后校验规则收紧，非法HTML结构直接抛错。另外原RangetoHTML函数缺少对目标区域的Copy操作，部分Excel版本下会粘贴出空内容。

采用直接读取本地签名文件的方案，彻底绕开异步加载的时序问题，同时剥离冗余HTML标签保证结构合法：

Sub BodyVsHTMLBody()
    Dim ol As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim sigContent As String
    Dim sigRootPath As String
    Dim customBody As String
    
    Set ol = New Outlook.Application
    Set olMail = ol.CreateItem(olMailItem)
    
    ' 读取本地默认签名存储路径
    sigRootPath = Environ("APPDATA") & "\Microsoft\Signatures\"
    ' 替换为你自己的默认签名htm文件名，可在上述路径下找到
    sigContent = GetFileContent(sigRootPath & "你的默认签名文件名.htm")
    
    ' 生成自定义正文，剥离冗余外层HTML标签
    customBody = ExtractHtmlBody(RangetoHTML(Sheet3.Range("C18")))

    With olMail
        .To = Sheet3.Range("C7").Value
        .CC = Sheet3.Range("C8").Value
        .Subject = Sheet3.Range("C9").Value
        .Attachments.Add Sheet3.Range("C11").Value
        .Attachments.Add Sheet3.Range("C12").Value
        ' 先拼接正文和签名，再调用Display，不会触发异步加载问题
        .HTMLBody = customBody & "<br><br>" & sigContent
        .Display
    End With
     
End Sub

' 读取文本/HTML文件通用方法
Function GetFileContent(ByVal filePath As String) As String
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(filePath).OpenAsTextStream(1, -2)
    GetFileContent = ts.ReadAll
    ts.Close
    Set ts = Nothing
    Set fso = Nothing
End Function

' 提取完整HTML中<body>标签内的实际内容，剥离冗余外层标签
Function ExtractHtmlBody(fullHtml As String) As String
    Dim bodyStart As Long, bodyEnd As Long
    bodyStart = InStr(1, fullHtml, "<body", vbTextCompare)
    If bodyStart > 0 Then
        bodyStart = InStr(bodyStart, fullHtml, ">", vbTextCompare) + 1
        bodyEnd = InStr(bodyStart, fullHtml, "</body>", vbTextCompare)
        ExtractHtmlBody = Mid(fullHtml, bodyStart, bodyEnd - bodyStart)
    Else
        ExtractHtmlBody = fullHtml
    End If
End Function

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    ' 补全原代码缺失的区域复制操作
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    TempWB.Close savechanges:=False

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

1. 打开Windows资源管理器，在地址栏输入%APPDATA%\Microsoft\Signatures按回车，就能看到本机存储的所有Outlook签名文件
2. 找到你日常发邮件默认使用的HTML格式签名（后缀为.htm），把文件名替换到代码中你的默认签名文件名.htm的位置
3. 如果需要调整正文和签名的间距，可以修改.HTMLBody拼接处的<br>标签数量

备选方案：如果不想手动配置签名文件名，也可以在原代码.Display行之后增加DoEvents和2秒左右的等待时间，等Outlook签名加载完成后再执行HTMLBody拼接，但该方案受机器性能、Outlook响应速度影响，稳定性不如直接读取签名文件的方案。

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