在有人建议之前，我花了几个小时仔细研究以前回答过的类似问题，但终生无法找到我要去的地方。如建议的那样，我的目标是将范围作为图像粘贴到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
答案 0 :(得分：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不会喜欢空格。
答案 1 :(得分：1)
据我所知，图片可以很好地粘贴到电子邮件的身体上，对吗？
在这种情况下，您可能只需要像这样添加.HTMLBody：
olMail.HTMLBody = "Text here," & vbNewLine & vbNewLine & _
"Today's report is attached." & vbNewLine & _
.HTMLBody & _
vbNewLine & vbNewLine & "More text here" & _
vbNewLine & vbNewLine & "Kind regards,"
答案 2 :(得分：0)
如果您的代码在迁移到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