Excel 2010将范围和图片粘贴到Outlook中

我很难找出这个问题。 我可以粘贴一个范围没有问题的HTML，但在一些沟通，我们希望超过范围作为一个图片，而不是。 我可以创build一个范围并将其保存为图片，但是我无法弄清楚如何在创build后将图片过滤到Outlook中。

如果您只是在寻找能够复制范围并将其粘贴到Outlook的代码，那么效果很好。 所有电子邮件数据都是在名为Mail的选项卡上引用单元格，因此只需将邮件选项卡和macros复制并粘贴到任何工作簿中，然后通过编辑邮件选项卡上的字段并不更改macros来添加电子邮件自动化。 如果使用此代码，请确保引用Microsoft Outlook xx对象库（在VBA窗口中：工具 – 参考 – Microsoft Outlook xx对象库）。

我需要更进一步，将范围变成图片并粘贴到电子邮件中。 我可以附加它，但我不能将它插入到身体，这是我所需要的。 我已经看了几个例子，包括Ron DeBruins网站上的例子，但是我还没能得到任何一个工作。 我正在使用Office 2010 x64运行Windows 7 x64。

这里是我正在运行的代码粘贴范围。

Option Explicit Sub Mail_AS_Range() ' Working in Office 2010-2013 Dim OutApp As Outlook.Application Dim OutMail As Outlook.MailItem Dim strbody As String On Error Resume Next Dim sh As Worksheet Set sh = Sheets("Mail") strbody = sh.Range("C9").Value Sheets(sh.Range("C11").Value).Select ActiveWorkbook.Save Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With OutMail .SentOnBehalfOfName = sh.Range("C4") 'This allows us to send from an alternate email address .Display 'Alternate send address will not work if we do not display the email first. 'I dont know why but this step is a MUST .To = sh.Range("C5") .CC = sh.Range("C6") .BCC = sh.Range("C7") .Subject = sh.Range("C8").Value .HTMLBody = "<br>" & strbody & fncRangeToHtml(sh.Range("C13").Value, sh.Range("C14").Value) & .HTMLBody ' This is where the body of the email is pulled together. ' <br> is an HTML tag to turn the text into HTML ' strbody is your text from cell C9 on the mail tab ' fncRangetoHtml is converting the range you specified into HTML ' .HTMLBody inserts your email signature .Attachments.Add sh.Range("C10").Value '.Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing End Sub Private Function fncRangeToHtml( _ strWorksheetName As String, _ strRangeAddress As String) As String ' This is creating a private function to make the range specified in the Mail macro into HTML Dim objFilesytem As Object, objTextstream As Object, objShape As Shape Dim strFilename As String, strTempText As String Dim blnRangeContainsShapes As Boolean strFilename = Environ$("temp") & "\" & _ Format(Now, "dd-mm-yy_h-mm-ss") & ".htm" ThisWorkbook.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=strFilename, _ Sheet:=strWorksheetName, _ Source:=strRangeAddress, _ HtmlType:=xlHtmlStatic).Publish True Set objFilesytem = CreateObject("Scripting.FileSystemObject") Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2) strTempText = objTextstream.ReadAll objTextstream.Close strTempText = Replace(strTempText, "align=center x:publishsource=", "align=left x:publishsource=") For Each objShape In Worksheets(strWorksheetName).Shapes If Not Intersect(objShape.TopLeftCell, Worksheets( _ strWorksheetName).Range(strRangeAddress)) Is Nothing Then blnRangeContainsShapes = True Exit For End If Next If blnRangeContainsShapes Then strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName)) fncRangeToHtml = strTempText Set objTextstream = Nothing Set objFilesytem = Nothing Kill strFilename End Function Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String Const HTM_START = "<link rel=File-List href=" Const HTM_END = "/filelist.xml" Dim strTemp As String Dim lngPathLeft As Long lngPathLeft = InStr(1, strTempText, HTM_START) strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft) strTemp = Replace(strTemp, HTM_START & Chr$(34), "") strTemp = Replace(strTemp, HTM_END & Chr$(34), "") strTemp = strTemp & "/" strTempText = Replace(strTempText, strTemp, Environ$("temp") & "\" & strTemp) fncConvertPictureToMail = strTempText End Function 

任何build议，将不胜感激。 谢谢！

Answer 1

谢谢BP_谁指示了我的链接，这回答了我的问题。 这是我的代码后修改我的应用程序。

这使我可以在Excel中设置选项卡中的所有variables，而不编辑查询本身。 我使用这种方法，因为我的团队中的一些人不习惯编辑VBA。

 Sub Mail_W_Pic() Dim TempFilePath As String Dim OutApp As Outlook.Application Dim OutMail As Outlook.MailItem Dim strbody As String Dim width As String Dim height As String On Error Resume Next Dim sh As Worksheet Set sh = Sheets("Mail") strbody = sh.Range("C9").Value Sheets(sh.Range("C11").Value).Select width = (sh.Range("C15").Value) height = (sh.Range("C16").Value) 'Create a new Microsoft Outlook session Set OutApp = CreateObject("outlook.application") 'create a new message Set OutMail = OutApp.CreateItem(olMailItem) With OutMail .SentOnBehalfOfName = sh.Range("C4") .Display .Subject = sh.Range("C8").Value .To = sh.Range("C5") .CC = sh.Range("C6") .BCC = sh.Range("C7") 'first we create the image as a JPG file Call createJpg(sh.Range("C13").Value, sh.Range("C14").Value, "DashboardFile") 'we attached the embedded image with a Position at 0 (makes the attachment hidden) TempFilePath = Environ$("temp") & "\" .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue, 0 'Then we add an html <img src=''> link to this image 'Note than you can customize width and height - not mandatory .HTMLBody = "<br>" & strbody & "<br><br>" _ & "<img src='cid:DashboardFile.jpg'" & "width=width height=heigth><br><br>" _ & "<br>Best Regards,<br>Ed</font></span>" & .HTMLBody .Display '.Send End With Set sh = Nothing End Sub Sub createJpg(Namesheet As String, nameRange As String, nameFile As String) ThisWorkbook.Activate Worksheets(Namesheet).Activate Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange) Plage.CopyPicture With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.width, Plage.height) .Activate .Chart.Paste .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG" End With Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete Set Plage = Nothing End Sub