Excel表格转图片插入Outlook邮件脚本粘贴异常求助

使用VBA尝试将Excel指定区域复制为图片并粘贴到Outlook邮件正文，脚本可正常打开邮件、填充收件人和主题，但邮件正文始终为空；手动右键可粘贴图片，脚本无法自动完成。

1. 错误被掩盖：代码开头的On Error Resume Next会忽略所有错误，比如wdChartPicture常量未定义（未引用Word对象库时，该常量不存在），直接导致粘贴操作失败。
2. 正文覆盖顺序错误：先通过WordEditor粘贴图片，再设置.HTMLBody会完全覆盖之前的内容，导致图片丢失。
3. 图片复制步骤冗余：先将Range粘贴为Excel内的Picture再剪切，不如直接复制Range后直接粘贴到邮件正文，步骤更高效且不易出错。

Sub send_email_with_table_as_pic()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim tableRange As Range
    Dim ws As Worksheet
    Dim wordDoc As Object
    
    ' 创建Outlook对象
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' 指定要复制的表格区域
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set tableRange = ws.Range("E26:H38")
    
    ' 直接复制区域为图片格式
    tableRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    ' 构建邮件
    With OutMail
        .To = "team@abc.com"
        .CC = ""
        .BCC = ""
        .Subject = "table data"
        ' 先设置HTML正文框架，避免后续覆盖粘贴内容
        .HTMLBody = "<BODY style='font-size:11pt; font-family:Arial'>Hi team, <p> Please see table below: <p></BODY>"
        .Display ' 必须先Display才能获取Word编辑对象
        
        ' 获取邮件的Word编辑实例
        Set wordDoc = OutMail.GetInspector.WordEditor
        ' 将光标移到正文末尾，确保图片插入位置正确
        wordDoc.Range(wordDoc.Content.End - 1, wordDoc.Content.End - 1).Select
        wordDoc.Application.Selection.Paste
        
        ' 添加结尾签名
        With wordDoc.Range
            .InsertParagraphAfter
            .InsertAfter "Thank you,"
            .InsertParagraphAfter
            .InsertAfter "Greg"
        End With
    End With
    
    ' 释放对象
    Set OutApp = Nothing
    Set OutMail = Nothing
    Set wordDoc = Nothing
End Sub

• 移除全局On Error Resume Next，便于排查代码错误；若需容错，建议仅包裹特定可能出错的代码块。
• 使用CopyPicture直接将Range复制为图片，省去中间生成Excel内Picture对象的步骤，减少出错概率。
• 调整正文设置顺序：先设置HTML框架，再粘贴图片，避免内容被覆盖。
• 明确光标位置后再粘贴，确保图片插入到指定位置。

• 确保Excel宏已启用：文件→选项→信任中心→信任中心设置→宏设置，选择符合安全需求的宏启用选项。
• Outlook需允许宏访问：文件→选项→信任中心→信任中心设置→宏设置，勾选"启用所有宏"，并勾选"信任对VBA项目对象模型的访问"。
• 若仍出现粘贴失败，可尝试添加DoEvents或短暂延迟（Application.Wait Now + TimeValue("00:00:01")），确保复制操作完成后再执行粘贴。

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