Excel VBA发送邮件后Outlook已发送项目中图片串位问题求助

阿华AIGC实验室

2026-4-30

问题根源分析

你遇到的图片串位问题，本质是所有邮件都共用了同一个临时图片文件名NamePicture.jpg。当你连续发送多封邮件（比如C1、C2、C3区域的邮件），后续邮件生成的图片会直接覆盖临时文件夹里的同名文件。而Outlook的已发送邮件和抄送邮件，是通过cid:NamePicture.jpg这个标识来引用本地临时文件的——当临时文件被后面的邮件替换后，再次打开已发送邮件时，Outlook就会加载最新的文件内容，导致图片串位、时对时错。

修复方案

我们需要给每封邮件生成唯一的临时图片文件名，避免互相覆盖；同时在邮件发送完成后清理临时文件，避免占用空间。

以下是修改后的完整代码：

Sub C_1()
' Ron de Bruin, 2019年10月25日
' 此宏使用名为: CopyRangeToJPG的函数
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim MakeJPG As String
Dim tempPicPath As String

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "Dear Sir" & "<br><br>" & _
          "Kindly find the retails performance dashboard for your reference." & "<br><br>" & _
          "Regards" & "<br>" & _
          "Manish Lengade<br>"

' 创建指定区域的JPG图片文件，生成唯一文件名（带时间戳）
tempPicPath = Environ$("temp") & Application.PathSeparator & "NamePicture_" & Format(Now(), "YYYYMMDDHHMMSS") & ".jpg"
MakeJPG = CopyRangeToJPG("Sheet 1", "B2:L15", tempPicPath)

If MakeJPG = "" Then
    MsgBox "出现错误，无法创建邮件"
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Exit Sub
End If

On Error Resume Next
With OutMail
    .To = "manish.lengade@maruti.co.in"
    .CC = ""
    .BCC = ""
    .Subject = "Retails Performance Dashboard"
    ' 附件加入唯一命名的图片，cid要和文件名一致
    .Attachments.Add MakeJPG, 1, 1
    ' 注意：cid要和图片文件名完全匹配
    .HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:" & Mid(MakeJPG, InStrRev(MakeJPG, "\") + 1) & """ width=1000 height=450></html>"
    .Display '或使用.Send
End With
On Error GoTo 0

' 发送完成后删除临时图片文件（可选，但建议清理）
On Error Resume Next
Kill MakeJPG
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String, savePath As String) As String
' Ron de Bruin, 2019年10月25日 - 修改为支持自定义保存路径
Dim PictureRange As Range

With ActiveWorkbook
    On Error Resume Next
    .Worksheets(NameWorksheet).Activate
    Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
    If PictureRange Is Nothing Then
        MsgBox "抱歉，这不是一个有效的区域"
        On Error GoTo 0
        Exit Function
    End If

    PictureRange.CopyPicture
    With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
        .Activate
        .Chart.Paste
        .Chart.Export savePath, "JPG"
    End With
    .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With

CopyRangeToJPG = savePath
Set PictureRange = Nothing
End Function

关键修改点说明