将 Excel 范围作为图片粘贴到电子邮件正文中

Question

我的目标是将范围作为图像粘贴到 Outlook 电子邮件中。我在 VBA 编辑器中打开了 MS Excel、Word 和 Outlook 15.0 的引用作为我网络上的最新版本。

我花了好几个小时查看以前回答过的类似问题。

我无法将图像保存为临时文件/使用 html 来引用附件作为解决方案，因为其他用户无权访问特定驱动器，如果他们在自己的机器上运行代码会临时保存该驱动器。

如果我删除电子邮件正文部分，图像会很好地粘贴，但是如果我将两段代码放在一起，则电子邮件正文会覆盖图像。但是，我确实需要将图像粘贴到电子邮件正文中。

Sub CreateEmail()

Dim OlApp As Object
Dim OlMail As Object
Dim ToRecipient As Variant
Dim CcRecipient As Variant
Dim PictureRange As Range
Dim OApp As Object, OMail As Object, signature As String

Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.createitem(olmailitem)

ExtractName = ActiveWorkbook.Sheets("macros").Range("C11").Value

ToRecipient = ActiveWorkbook.Sheets("macros").Range("K11")
OlMail.Recipients.Add ToRecipient

CC_Check = ActiveWorkbook.Sheets("macros").Range("k10")
If CC_Check = "" Then GoTo Skip_CC

CcRecipient = ActiveWorkbook.Sheets("macros").Range("K10")

OlMail.Recipients.Add CcRecipient

OlMail.Subject = ExtractName
signature = OlMailbody
With OlMail
Set PictureRange = ActiveWorkbook.Sheets("DCTVV").Range("A2:D13")
PictureRange.Copy
OlMail.Display

'This section pastes the image             

Dim wordDoc As Word.Document
Set wordDoc = OlMail.GetInspector.WordEditor
wordDoc.Range.PasteAndFormat wdChartPicture

'This section is the email body it needs inserting into

OlMail.body = "Text here," & vbNewLine & vbNewLine & _
        "Today's report is attached." & vbNewLine & _
        "IMAGE NEEDS TO BE PASTED HERE" _
      & vbNewLine & vbNewLine & "More text here" _
      & vbNewLine & vbNewLine & "Kind regards,"
.signature

End With
Set OMail = Nothing
Set OApp = Nothing
OlMail.Attachments.Add ("filepath &attachment1")
OlMail.Attachments.Add ("filepath &attachment2")
'OlMail.Attachments.Add ("filepath &attachment3")

OlMail.Display 

End Sub

Answer 1

如果您的代码在迁移到 Office 365 后突然停止工作或由于任何其他原因，请参阅下面的代码。添加了注释以便于理解和实施。

如果您拥有管理权限，请尝试以下链接中的注册表更改： https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo

但是，作为开发人员，我建议使用与所有 Excel 版本相当兼容的代码，而不是进行系统更改，因为每个最终用户的计算机也需要进行系统更改。

由于下面的 VBA 代码使用“后期绑定”，它还兼容所有以前和当前版本的 MS Office 即。 Excel 2003、Excel 2007、Excel 2010、Excel 2013、Excel 2016、Office 365

---

Option Explicit

Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)


    Dim rngToPicture As Range
    Dim outlookApp As Object
    Dim Outmail As Object
    Dim strTempFilePath As String
    Dim strTempFileName As String
    
    'Name it anything, doesn't matter
    strTempFileName = "RangeAsPNG"
    
    'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
    Set rngToPicture = Range("rngToPicture")
    Set outlookApp = CreateObject("Outlook.Application")
    Set Outmail = outlookApp.CreateItem(olMailItem)
  
    'Create an email
    With Outmail
        .To = strTo
        .Subject = strSubject
        
        'Create the range as a PNG file and store it in temp folder
        Call createPNG(rngToPicture, strTempFileName)
        
        'Embed the image in Outlook
        strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
        .Attachments.Add strTempFilePath, olByValue, 0

        'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
        .HTMLBody = "<img src='cid:" & strTempFileName & ".png' style='border:0'>"

        
        .Display
        
    End With

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

End Sub

Sub createPNG(ByRef rngToPicture As Range, nameFile As String)

    Dim wksName As String
    
    wksName = rngToPicture.Parent.Name
    
    'Delete the existing PNG file of same name, if exists
    On Error Resume Next
        Kill Environ$("temp") & "\" & nameFile & ".png"
    On Error GoTo 0
    
    'Copy the range as picture
    rngToPicture.CopyPicture
    
    'Paste the picture in Chart area of same dimensions
    With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
        .Activate
        .Chart.Paste
        'Export the chart as PNG File to Temp folder
        .Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
    End With
    Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete

End Sub

Answer 2

据我了解，图片可以很好地粘贴到电子邮件的正文中，对吧？

在这种情况下，您可能只需要像这样添加.HTMLBody：

olMail.HTMLBody = "Text here," & vbNewLine & vbNewLine & _
        "Today's report is attached." & vbNewLine & _
        .HTMLBody & _
        vbNewLine & vbNewLine & "More text here" & _
        vbNewLine & vbNewLine & "Kind regards,"

Answer 3

这是我在工作中发送电子邮件时使用的代码示例：

    Call CrearImagen
    ReDim myFileList(0 To Contador - 1)
    For i = 0 To Contador - 1
        myFileList(i) = wb.Path & "\" & Servicio & i & ".jpg"
        ImagenesBody = ImagenesBody & "<img src='cid:" & Servicio & i & ".jpg'>"
    Next i

    With OutMail
        .SentOnBehalfOfName = "ifyouwanttosendonbehalf"
        .Display
        .To = Para
        .CC = CC
        .BCC = ""
        .Subject = Asunto
        For i = 0 To UBound(myFileList)
            .Attachments.Add myFileList(i)
        Next i
        Dim Espacios As String

        Espacios = "<br>"
        For i = 0 To x
            Espacios = Espacios + "<br>"
        Next

        .HTMLBody = Saludo & "<br><br>" & strbody & "<br><br><br>" _
            & ImagenesBody _ 'here are the images
            & Espacios _ 'more text
            & .HTMLBody
        .Display
    End With
    On Error GoTo 0

'Reformateamos el tamaño de las imagénes y su posición relativa al texto

    Dim oL As Outlook.Application

    Set oL = GetObject("", "Outlook.application")
    Const wdInlineShapePicture = 3
    Dim olkMsg As Outlook.MailItem, wrdDoc As Object, wrdShp As Object
    Set olkMsg = oL.Application.ActiveInspector.CurrentItem
    Set wrdDoc = olkMsg.GetInspector.WordEditor
    For Each wrdShp In wrdDoc.InlineShapes
        If wrdShp.Type = wdInlineShapePicture Then
            wrdShp.ScaleHeight = 100
            wrdShp.ScaleWidth = 100
        End If
        If wrdShp.AlternativeText Like "cid:Imagen*.jpg" Then wrdShp.ConvertToShape
    Next

'Limpiamos los objetos
    For i = 0 To UBound(myFileList)
        Kill myFileList(i)
    Next i
    Set olkMsg = Nothing
    Set wrdDoc = Nothing
    Set wrdShp = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing

现在，如果您已经可以创建图像，只需将它们保存在工作簿路径中，您就可以像这样附加它们。在附加图片时，我建议你文件的名称不包含空格，这很难找到，直到弄清楚，html 不喜欢它们有空格。