如何用VBA将ActiveX中的图片添加为Outlook邮件附件

问题出在SavePicture方法——它只能将StdPicture对象保存为BMP格式，导致文件体积过大。我们可以复用你已经用到的Chart对象导出PNG的思路，把ActiveX图片框里的图片转存为PNG。

步骤1：新增图片转存子过程 #

添加一个专门处理ActiveX图片控件转PNG的子过程：

Sub SaveImageControlAsPNG(imgCtrl As MSForms.Image, savePath As String)
    Dim tempChart As ChartObject
    Dim ws As Worksheet
    
    ' 清理已存在的目标文件
    On Error Resume Next
    Kill savePath
    On Error GoTo 0
    
    Set ws = imgCtrl.Parent
    ' 创建与图片控件尺寸一致的临时Chart
    Set tempChart = ws.ChartObjects.Add( _
        Left:=0, Top:=0, _
        Width:=imgCtrl.Width, Height:=imgCtrl.Height)
    
    With tempChart
        .Activate
        ' 粘贴图片到Chart
        imgCtrl.Picture.Paste
        ' 隐藏Chart边框
        .Chart.ChartArea.Format.Line.Visible = msoFalse
        ' 导出为PNG
        .Chart.Export savePath, "PNG"
        ' 删除临时Chart
        .Delete
    End With
End Sub

步骤2：修改主过程中的图片保存逻辑 #

把你原代码中保存ICPhoto图片的部分替换成调用上面的子过程：

' 替换原有的图片保存代码段
imgPath = Environ$("temp") & "\Exportedimage.png"
If Not Worksheets("Email Template").ICPhoto.Picture Is Nothing Then
    ' 调用新的转存过程
    Call SaveImageControlAsPNG(Worksheets("Email Template").ICPhoto, imgPath)
    .Attachments.Add imgPath
End If

完整修改后的主过程代码 #

Private Sub CBSubmitButton_Click()

' Email out Report

Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
Dim imgPath As String
Dim strPDFPath As String

strPDFPath = "https://fcx365.sharepoint.com/Sites/STO-TEC/ProjectFiles/Assignments/240925%20%2D%20Shift%20Report%20Refresh/" _
    & saveName & ".pdf"

strTempFileName = "RangeAsPNG"

Set rngToPicture = Worksheets("Email Template").Range("A1:P74")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)

With Outmail
    .To = Join(Application.Transpose(Worksheets("Lists").Range("I2:I24")), ";")
    .Subject = "Shift Report"

    ' Create a picture of the report to add to the body of the email
    Call createPNG(rngToPicture, strTempFileName)
    
    strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
    .Attachments.Add strTempFilePath, olByValue, 0
    .Attachments.Add strPDFPath

    ' 处理ActiveX图片框的PNG导出
    imgPath = Environ$("temp") & "\Exportedimage.png"
    If Not Worksheets("Email Template").ICPhoto.Picture Is Nothing Then
        Call SaveImageControlAsPNG(Worksheets("Email Template").ICPhoto, imgPath)
        .Attachments.Add imgPath
    End If

    .HTMLBody = "<img src='cid:" & strTempFileName & ".png' style='border:0'>"
    .Display
    '    .Send

End With

Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing

End Sub

' 保留原有的createPNG子过程
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
    Dim Email_Pic As String
    Email_Pic = rngToPicture.Parent.Name

    On Error Resume Next
    Kill Environ$("temp") & "\" & nameFile & ".png"
    On Error GoTo 0

    rngToPicture.CopyPicture
    With ThisWorkbook.Worksheets(Email_Pic).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
        .Activate
        .Chart.Paste
        .Chart.ChartArea.Format.Line.Visible = msoFalse
        .Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
    End With
    Worksheets(Email_Pic).ChartObjects(Worksheets(Email_Pic).ChartObjects.Count).Delete
End Sub

' 新增的图片转存子过程
Sub SaveImageControlAsPNG(imgCtrl As MSForms.Image, savePath As String)
    Dim tempChart As ChartObject
    Dim ws As Worksheet
    
    On Error Resume Next
    Kill savePath
    On Error GoTo 0
    
    Set ws = imgCtrl.Parent
    Set tempChart = ws.ChartObjects.Add( _
        Left:=0, Top:=0, _
        Width:=imgCtrl.Width, Height:=imgCtrl.Height)
    
    With tempChart
        .Activate
        imgCtrl.Picture.Paste
        .Chart.ChartArea.Format.Line.Visible = msoFalse
        .Chart.Export savePath, "PNG"
        .Delete
    End With
End Sub

关键说明 #

• 利用Excel的Chart对象作为中间载体，因为Chart的Export方法支持PNG/JPG等压缩格式
• 临时Chart创建在图片控件所在工作表，用完立即删除，不会留下痕迹
• 导出的PNG文件体积会比BMP小很多，同时保留图片清晰度

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