如何将Excel工作表中的图片插入邮件正文？现有VBA代码求修改

原批量发邮件VBA代码无法处理从PowerPoint直接复制粘贴到Excel的PNG图片（这类图片未保存到本地系统，无可用访问路径）。以下是修改后的完整代码及关键说明：

关键修改说明 #

• 保留原区域内的图片对象，不再删除DrawingObjects
• 临时将内嵌图片保存到系统临时目录，生成可访问的绝对路径
• 转换HTML中的图片相对路径为绝对路径，确保Outlook能正确加载
• 邮件发送后自动清理临时文件及图片文件夹，避免磁盘残留
• 优化代码兼容性，无需引用Outlook库即可运行

修改后的完整代码 #

Sub Mail_Macro_High_Productivity()

Dim EmailApp As Object
Dim EmailItem As Object
Dim tbl_rng As String
Dim rng As Range
Dim ToEmail, CcEmail, Subject, ghNewBody, sht_name, signature As String
Dim i As Integer
Dim htmlContent As String
Dim tempPath As String ' 记录临时文件路径用于后续清理

    i = 2
    
'//  遍历高效邮件模板表格，获取变量值  //

    Do While Sheets("High Productivity Mail Template").Range("B" & i) <> ""

        Set EmailApp = CreateObject("Outlook.Application")
        Set EmailItem = EmailApp.CreateItem(0) ' olMailItem=0，兼容未引用Outlook库的场景
        sht_name = Sheets("High Productivity Mail Template").Range("C" & i)
        tbl_rng = Sheets("High Productivity Mail Template").Range("D" & i)
        Set rng = Sheets(sht_name).Range(tbl_rng)
        Sheets("High Productivity Mail Template").Activate
        ToEmail = Sheets("High Productivity Mail Template").Range("F" & i)
        CcEmail = Sheets("High Productivity Mail Template").Range("G" & i)
        Subject = Sheets("High Productivity Mail Template").Range("H" & i)
    
        With EmailItem
            .To = ToEmail
            .CC = CcEmail
            .BCC = " "
            .Subject = Subject

            ghNewBody = "<font style=""font-family: Calibri; font-size: 11pt;""></font>" & _
                        Range("J" & i) & "<br>" & "<br>" & Range("K" & i) & Range("L" & i)

            signature = CreateObject("Scripting.FileSystemObject").GetFile("C:\Users\Joynewton.K\AppData\Roaming\Microsoft\Signatures\Joy Newton Kapildev.htm").OpenAsTextStream(1, -2).ReadAll

            ' 调用修改后的RangetoHTML，获取HTML内容和临时路径
            htmlContent = RangetoHTML(rng, tempPath)

            .HTMLBody = ghNewBody & "<br><br>" & htmlContent & _
             "<br>" & "<br>" & signature

            '.display  //  取消注释可在发送前预览邮件  //
            .send
        End With

        ' 清理临时文件和文件夹
        If tempPath <> "" Then
            On Error Resume Next
            Kill tempPath ' 删除htm文件
            Kill Replace(tempPath, ".htm", ".files\*.*") ' 删除files文件夹内的所有文件
            RmDir Replace(tempPath, ".htm", ".files") ' 删除files文件夹
            On Error GoTo 0
        End If

        Set EmailApp = Nothing
        Set EmailItem = Nothing
        Set rng = Nothing
        Sheets("High Productivity Mail Template").Range("M" & i).Value = "Mail Sent"
    
    i = i + 1

    Loop

End Sub


Function RangetoHTML(rng As Range, ByRef tempFilePath As String) As String

Dim fso As Object
Dim ts As Object
Dim TempWB As Workbook
Dim tempFolder As String

'//  复制区域并创建临时工作簿接收数据  //

    tempFolder = Environ$("temp") & "/"
    tempFilePath = tempFolder & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)

    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8 ' 复制列宽
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        ' 保留图片对象，不再删除
        On Error GoTo 0
    End With

'//  将工作表发布为htm文件  //

    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=tempFilePath, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

'//  读取htm文件内容并调整图片路径为绝对路径  //

    Set fso = CreateObject("Scripting.FileSystemobject")
    Set ts = fso.GetFile(tempFilePath).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    
    ' 将相对路径替换为绝对file:///路径，确保Outlook能加载图片
    RangetoHTML = Replace(RangetoHTML, "src=""files/", "src=""file:///" & Replace(tempFolder, "/", "\") & Replace(tempFilePath, ".htm", ".files\") & "")
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")

'//  关闭临时工作簿  //

    TempWB.Close savechanges:=False
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

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