跨设备运行邮件发送宏时嵌入JPG无法显示的问题求助

问题现象 #

基于教程编写的VBA宏，可将Excel指定范围转为JPG嵌入Outlook邮件正文。本地运行正常，但同事设备上直接发送邮件时嵌入的JPG显示红叉，若先通过.Display显示邮件再手动发送，则图片显示正常。

问题原因 #

直接调用.Display后立刻执行.Send时，Outlook可能尚未完成附件与HTML正文的关联同步（尤其是不同版本、系统资源不足的环境下），导致邮件发送时图片的引用关系未建立，最终显示红叉。.Display会触发Outlook加载所有内容，但同步需要一定时间，直接发送会跳过这个过程。

解决方案 #

方案1：添加延迟（简单临时解决） #

在.Display和.Send之间添加等待时间，给Outlook足够时间完成同步：

.Display
.Save
' 等待2秒，可根据实际情况调整
Application.Wait Now + TimeValue("00:00:02")
.Send

方案2：使用CID关联图片（更可靠的永久解决） #

通过设置附件的CID（内容ID），让HTML正文直接引用这个ID，完全脱离本地文件路径依赖，避免同步问题。

修改后的完整代码：

Sub PasteRangeinMail()
    Dim FilePath As String
    Dim Outlook As Object
    Dim OutlookMail As Object
    Dim HTMLBody As String
    Dim rng As Range
    Dim lastday As String
    Dim imgCID As String
    
    Worksheets("X").Activate
    lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    Set rng = Range("A1:J" & lastrow)
    
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Set Outlook = CreateObject("outlook.application")
    Set OutlookMail = Outlook.CreateItem(0) ' olMailItem=0，避免依赖Outlook常量
    Call createImage(ActiveSheet.Name, rng.Address, "RangeImage")
    FilePath = "Y" ' 确保此处是图片的完整路径，比如"C:\Temp\"
    imgCID = "RangeImageCID" ' 自定义CID
    
    lastday = Format(Date - 2, "DD MMMM YYYY")
    
    ' HTML正文引用CID
    HTMLBody = "<span LANG=EN>" _
    & "<p class=style1><span LANG=EN><font FACE=Times New Roman SIZE=4>" _
    & "Dear All,<br>" _
    & "<br>" _
    & "PLACEHOLDER" & lastday & ":<br> " _
    & "<br>" _
    & "<img src='cid:" & imgCID & "'>" _
    & "<br>" _
    & "<br>Regards, <br><br> PLACEHOLDER</font></span>"
    
    With OutlookMail
        .Subject = "PLACEHOLDER" & lastday
        .HTMLBody = HTMLBody
        ' 添加附件并设置CID
        .Attachments.Add FilePath & "RangeImage.jpg", 1 ' olByValue=1
        .Attachments(.Attachments.Count).PropertyAccessor.SetProperty _
            "http://schemas.microsoft.com/mapi/proptag/0x3712001F", imgCID
        .To = "xxx@xxx.com "
        .CC = "yyy@yyy.com"
        .Send ' 无需Display也能正常显示图片
    End With
    
    ' 恢复应用设置
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub


Sub createImage(SheetName As String, rngAddrss As String, nameFile As String)
    Dim rngJpg As Range
    Dim Shape As Shape
    Dim exportPath As String
    exportPath = "XXXX\YYYY\" & nameFile & ".jpg" ' 确保路径正确
    
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set rngJpg = ThisWorkbook.Worksheets(SheetName).Range(rngAddrss)
    rngJpg.CopyPicture
    
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(rngJpg.Left, rngJpg.Top, rngJpg.Width, rngJpg.Height)
        .Activate
        For Each Shape In ActiveSheet.Shapes
            Shape.Line.Visible = msoFalse
        Next
        .Chart.Paste
        .Chart.Export exportPath, "JPG"
    End With
    
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
    Set rngJpg = Nothing
End Sub

代码说明 #

1. 使用olMailItem的数值0、olByValue的数值1，避免因未引用Outlook对象库导致的常量未定义问题
2. 通过PropertyAccessor给附件设置CID，HTML正文用cid:xxx直接引用，无需依赖本地文件路径
3. 恢复了Application的默认设置（原代码未恢复，可能导致后续Excel操作异常）
4. 明确了图片导出路径，避免路径拼接错误

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