VBA自动生成邮件内嵌图片时最后一张图片错乱的排查与解决

我编写了一段用于自动化任务的VBA脚本，该脚本会刷新指定的Power Query和数据透视表，并将结果复制为图片嵌入邮件。但最后一张图片总是出现多个区域内容重叠的错乱情况。以下是原代码：

Sub PasteRangeinMail()
Dim FilePath As String
Dim Outlook As Object
Dim OutlookMail As Object
Dim HTMLBody As String
Dim rng As Range
Dim dtToday As String
Dim lRow, lRow2 As Long

' Update
Sheets("Inbase_Activation").ListObjects("Inbase_Activation").QueryTable.Refresh False
Sheets("Inbase_Pending_Activation").ListObjects("Inbase_Pending_Activation").QueryTable.Refresh False
ThisWorkbook.RefreshAll
Application.Wait (Now + TimeValue("00:00:10"))

' Today
dtToday = Format(Date, "YYYYMMDD") - 2

' Rng
On Error Resume Next
Set rng = ThisWorkbook.Sheets("Activation NAC").Range("A1:J14")
If rng Is Nothing Then Exit Sub
Call createImage("Activation NAC", rng.Address, "RangeImage")
Application.CutCopyMode = False

' Rng2
On Error Resume Next
Set rng2 = ThisWorkbook.Sheets("Pending NAC").Range("A1:J14")
If rng2 Is Nothing Then Exit Sub
Call createImage("Pending NAC", rng2.Address, "RangeImage") ' 文件名重复问题
Application.CutCopyMode = False

' Rng3
ThisWorkbook.Sheets("Activation Bulk Case").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set rng3 = ThisWorkbook.Sheets("Activation Bulk Case").Range("A1:C" & lRow)
If rng3 Is Nothing Then Exit Sub
Call createImage("Activation Bulk Case", rng3.Address, "RangeImage3")
Application.CutCopyMode = False

' Rng4
ThisWorkbook.Sheets("Pending Bulk Case").Select
lRow2 = Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set rng4 = ThisWorkbook.Sheets("Pending Bulk Case").Range("A1:C" & lRow2)
If rng4 Is Nothing Then Exit Sub
Call createImage("Pending Bulk Case", rng4.Address, "RangeImage4")
Application.CutCopyMode = False

' Off
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With

' Mail
Set Outlook = CreateObject("outlook.application")
Set OutlookMail = Outlook.CreateItem(olMailItem)
FilePath = Environ$("temp") & "\"
HTMLBody = "<span LANG=EN>" _
&amp; "" _
&amp; "Dear Jess," _
&amp; "<br>" _
&amp; "Please find MTD result of 5GBB activation as of " & dtToday & ":<br> " _
&amp; "<br>" _
&amp; "<img src='cid:RangeImage.jpg'>" _
&amp; "<br>" _
&amp; "<img src='cid:RangeImage2.jpg'>" _
&amp; "<br>" _
&amp; "<img src='cid:RangeImage3.jpg'>" _
&amp; "<br>" _
&amp; "<img src='cid:RangeImage4.jpg'>" _
&amp; "<br>" _
&amp; "<br>Regards</font></span>"

With OutlookMail
.Subject = "Inbase Summary as of " & dtToday
.HTMLBody = HTMLBody
.Attachments.Add FilePath & "RangeImage.jpg", olByValue
.Attachments.Add FilePath & "RangeImage2.jpg", olByValue ' 引用的文件实际不存在
.Attachments.Add FilePath & "RangeImage3.jpg", olByValue
.Attachments.Add FilePath & "RangeImage4.jpg", olByValue
.To = " "
.CC = " "
.Display
End With

' On
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Sub createImage(sheetName As String, rangeAddress As String, imageName As String)
    Dim ws As Worksheet
    Dim rng As Range
    Dim fileName As String

    Set ws = ThisWorkbook.Sheets(sheetName)
    Set rng = ws.Range(rangeAddress)

    fileName = Environ$("temp") & "\" & imageName & ".jpg"

    rng.CopyPicture
    With ws.ChartObjects.Add(rng.Left, rng.Top, rng.Width, rng.Height)
        .Activate
        For Each Shape In ActiveSheet.Shapes
            Shape.Line.Visible = msoFalse
        Next
        .Chart.Paste
        .Chart.Export fileName, "JPG"
    End With

    ws.ChartObjects(ws.ChartObjects.Count).Delete
    Set rng = Nothing
End Sub

问题原因 #

1. 文件名重复覆盖：生成第二张图片时使用了和第一张相同的imageName，导致RangeImage.jpg被覆盖，但HTML中引用的RangeImage2.jpg实际不存在，后续图片生成因文件缓存或资源占用出现错乱。
2. 未等待粘贴完成就导出：createImage函数中粘贴图片到图表后立即导出，未等待系统完成粘贴操作，导致内容渲染不完整。
3. 依赖ActiveSheet操作：遍历ActiveSheet.Shapes可能误操作其他工作表的形状，干扰图片生成。
4. 固定等待刷新时间：Application.Wait固定等待10秒，若数据刷新未完成就生成图片，会截取到未更新的内容或导致重叠。

解决方法 #

1. 修正图片命名：确保每个图片使用唯一的imageName，与HTML中的引用一一对应。
2. 优化createImage函数：
   • 指定CopyPicture的参数为xlScreen, xlPicture，确保复制格式正确。
   • 用变量保存ChartObject，避免通过Count删除导致的错误。
   • 添加DoEvents等待粘贴完成后再导出。
3. 等待刷新完成：替换固定等待时间，改为检查所有QueryTable的刷新状态，确保数据完全更新。
4. 提前关闭界面干扰：在脚本开头就关闭ScreenUpdating、EnableEvents等，避免界面操作影响图片生成。

修改后的完整代码 #

Sub PasteRangeinMail()
Dim FilePath As String
Dim Outlook As Object
Dim OutlookMail As Object
Dim HTMLBody As String
Dim rng As Range, rng2 As Range, rng3 As Range, rng4 As Range
Dim dtToday As String
Dim lRow, lRow2 As Long
Dim ws As Worksheet
Dim qt As QueryTable

' 提前关闭界面干扰
With Application
    .Calculation = xlManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

' Update - 等待所有刷新完成
Sheets("Inbase_Activation").ListObjects("Inbase_Activation").QueryTable.Refresh BackgroundQuery:=False
Sheets("Inbase_Pending_Activation").ListObjects("Inbase_Pending_Activation").QueryTable.Refresh BackgroundQuery:=False
ThisWorkbook.RefreshAll

' 检查所有QueryTable是否完成刷新
For Each ws In ThisWorkbook.Sheets
    For Each qt In ws.QueryTables
        Do While qt.Refreshing
            DoEvents
        Loop
    Next qt
Next ws

' Today - 修正日期计算方式
dtToday = Format(Date - 2, "YYYYMMDD")

' Rng
Set rng = ThisWorkbook.Sheets("Activation NAC").Range("A1:J14")
If Not rng Is Nothing Then
    Call createImage("Activation NAC", rng.Address, "RangeImage")
End If
Application.CutCopyMode = False

' Rng2 - 使用唯一的imageName
Set rng2 = ThisWorkbook.Sheets("Pending NAC").Range("A1:J14")
If Not rng2 Is Nothing Then
    Call createImage("Pending NAC", rng2.Address, "RangeImage2")
End If
Application.CutCopyMode = False

' Rng3 - 避免Select操作
With ThisWorkbook.Sheets("Activation Bulk Case")
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set rng3 = .Range("A1:C" & lRow)
End With
If Not rng3 Is Nothing Then
    Call createImage("Activation Bulk Case", rng3.Address, "RangeImage3")
End If
Application.CutCopyMode = False

' Rng4 - 避免Select操作
With ThisWorkbook.Sheets("Pending Bulk Case")
    lRow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set rng4 = .Range("A1:C" & lRow2)
End With
If Not rng4 Is Nothing Then
    Call createImage("Pending Bulk Case", rng4.Address, "RangeImage4")
End If
Application.CutCopyMode = False

' Mail
Set Outlook = CreateObject("outlook.application")
Set OutlookMail = Outlook.CreateItem(olMailItem)
FilePath = Environ$("temp") & "\"
HTMLBody = "<span LANG=EN>" _
&amp; "Dear Jess," _
&amp; "<br>" _
&amp; "Please find MTD result of 5GBB activation as of " & dtToday & ":<br> " _
&amp; "<br>" _
&amp; "<img src='cid:RangeImage.jpg'>" _
&amp; "<br>" _
&amp; "<img src='cid:RangeImage2.jpg'>" _
&amp; "<br>" _
&amp; "<img src='cid:RangeImage3.jpg'>" _
&amp; "<br>" _
&amp; "<img src='cid:RangeImage4.jpg'>" _
&amp; "<br><br>Regards</span>"

With OutlookMail
    .Subject = "Inbase Summary as of " & dtToday
    .HTMLBody = HTMLBody
    .Attachments.Add FilePath & "RangeImage.jpg", olByValue
    .Attachments.Add FilePath & "RangeImage2.jpg", olByValue
    .Attachments.Add FilePath & "RangeImage3.jpg", olByValue
    .Attachments.Add FilePath & "RangeImage4.jpg", olByValue
    .To = " "
    .CC = " "
    .Display
End With

' 恢复系统设置
With Application
    .Calculation = xlAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
End With

' 释放对象
Set Outlook = Nothing
Set OutlookMail = Nothing
Set rng = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set rng4 = Nothing
End Sub

Sub createImage(sheetName As String, rangeAddress As String, imageName As String)
    Dim ws As Worksheet
    Dim rng As Range
    Dim fileName As String
    Dim chartObj As ChartObject

    Set ws = ThisWorkbook.Sheets(sheetName)
    Set rng = ws.Range(rangeAddress)
    fileName = Environ$("temp") & "\" & imageName & ".jpg"

    ' 以图片格式复制区域
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ' 创建与区域大小一致的图表对象
    Set chartObj = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    
    With chartObj.Chart
        .Paste ' 粘贴图片到图表
        DoEvents ' 等待粘贴完成
        .Export fileName, "JPG" ' 导出为图片
    End With

    chartObj.Delete ' 删除临时图表
    ' 释放对象
    Set rng = Nothing
    Set chartObj = Nothing
    Set ws = Nothing
End Sub

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