Excel VBA宏求助：邮件中插入的单元格图片显示空白

问题场景 #

通过Excel VBA宏将A-Q列指定单元格以图片形式发送给同事，执行宏后邮件草稿中的图片显示空白，但剪贴板中存在正确的单元格图片，手动粘贴可正常显示，需要实现完全自动化供部门使用。

问题根源分析 #

1. 图表渲染不及时：复制单元格为图片后直接粘贴到图表并导出，未等待系统完成渲染，导致导出的临时图片为空
2. 附件与HTMLBody顺序错误：先设置HTMLBody再添加附件，Outlook无法正确关联cid对应的图片资源
3. 临时文件过早删除：邮件刚显示就删除临时图片，此时Outlook还未完成图片加载
4. 工作表删除逻辑错误：Sheets(1).Delete执行前未关闭警告提示，且位置不合理

修正后的代码 #

Sub CAS_Reminder()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Rng As Range
    Dim LastRow As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Recipient_Name As String
    Dim StringBody As String
    Dim Manager_Name As String
    Dim RngHeight As Long
    Dim RngWidth As Long
    
    ' 更可靠的获取最后一行（避免A列中间有空行）
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 设置要复制的范围
    Set Rng = Range("A1:Q" & LastRow)
    
    ' 复制范围为图片
    Rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    ' 创建临时文件路径
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "SelectedRanges.png"
    
    ' 复制图片到图表并导出，增加等待确保渲染完成
    With ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=Rng.Width, Height:=Rng.Height)
        .Chart.Paste
        DoEvents ' 等待系统完成图片渲染
        .Chart.Export FileName:=TempFilePath & TempFileName, FilterName:="PNG"
        .Delete
    End With
    
    ' 存储范围尺寸
    RngHeight = Rng.Height
    RngWidth = Rng.Width
    
    ' 创建Outlook邮件
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' 设置收件人
    Recipient_Name = Range("Q2").Value & "@harriscomputer.com"
    Manager_Name = Range("D2").Value & "@harriscomputer.com"
    
    ' 先添加附件，再设置HTMLBody，确保cid关联有效
    With OutMail
        .To = Recipient_Name
        .CC = Manager_Name
        .Subject = "xxx"
        ' 添加图片作为嵌入式附件（Type=1表示嵌入式）
        .Attachments.Add TempFilePath & TempFileName, 1, 0
        ' 设置HTML正文，注意cid要和附件文件名完全一致
        StringBody = "xxx" & _
                  "<img src='cid:SelectedRanges.png' height='" & RngHeight & "' width='" & RngWidth & "'>"
        .HTMLBody = StringBody
        .Display
    End With
    
    ' 清理操作：建议在邮件关闭后再删除临时文件，避免加载问题
    ' Kill TempFilePath & TempFileName
    
    ' 修正工作表删除逻辑：先关闭警告再删除
    Application.DisplayAlerts = False
    Sheets(1).Delete
    Application.DisplayAlerts = True ' 恢复警告设置，避免影响后续操作
    
    ' 释放对象
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

关键修改说明 #

• 获取最后一行优化：改用Cells(Rows.Count, "A").End(xlUp).Row，避免A列中间有空行时获取错误的最后一行
• 增加渲染等待：添加DoEvents让系统有时间将剪贴板中的图片渲染到图表，确保导出的图片完整
• 调整附件与HTML顺序：先添加嵌入式附件，再设置HTMLBody，让Outlook能正确识别cid对应的图片资源
• 修正工作表删除逻辑：先设置Application.DisplayAlerts = False再删除工作表，避免弹出确认提示，操作完成后恢复警告设置
• 临时文件删除调整：注释掉过早删除临时文件的代码，建议在邮件关闭后再删除，防止Outlook加载图片时文件已被删除

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