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

此部分粘贴图像

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

此部分是需要插入的电子邮件正文

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

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

    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不会喜欢空格。

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

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

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

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

由于下面的VBA代码使用“后期绑定”，因此它也与MS Office viz的所有以前和当前版本兼容。 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

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

3 个答案: