VBA：给范围和图像发送电子邮件

我有每天生成的报告。 这个报告包含大约7个图表，1个表格（只是普通的excel单元格组）和一些格式化的合并单元格。

我已经写了一大堆的VBA来自动化这个报告，现在我正在想自动发送这个报告。 我试图寻找http://www.rondebruin.nl/这似乎是正常的电子邮件从Excel正常的第一个端口，但我似乎无法find我在找什么。

我试图复制的function是

• 复制范围（“H5：N100”）
• 在主题为“X”的Outlook中创build新电子邮件
• select性粘贴（Enchance Meta文件或位图通常会提供最佳效果）
• 发送电子邮件给收件人“Y”

我的问题是，我不希望附加文件，我需要的图表。 当转换为HTML我似乎失去了图表和奇怪的某些合并单元格中的渐变丢失。

编辑：按要求我目前正在使用的代码

Sub Mail_Selection_Range_Outlook_Body() Dim rng As Range Dim Sxbdy As Range Dim OutApp As Object Dim OutMail As Object Set SxRvSht = Application.ThisWorkbook.Worksheets("Report") On Error Resume Next SxRvSht.Select Set Sxbdy = Worksheets("Report").Range("H5:N100") On Error GoTo 0 If Sxbdy Is Nothing Then MsgBox "The selection is not a range or the sheet is protected" & _ vbNewLine & "please correct and try again.", vbOKOnly Exit Sub End If With Application .EnableEvents = False .ScreenUpdating = False End With Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .To = "[e-mail]" .CC = "" .BCC = "" .Subject = "SUBJECT!!!" .HTMLBody = RangetoHTML(Sxbdy) .display '.send End With On Error GoTo 0 With Application .EnableEvents = True .ScreenUpdating = True End With Set OutMail = Nothing Set OutApp = Nothing End Sub Function RangetoHTML(Sxbdy As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2010 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 'Copy the range and create a new workbook to past the data in 'rng.Copy Set TempWB = Workbooks.Add(1) Sxbdy.Copy With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With Application.CutCopyMode = False 'Publish the sheet to a htm file With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With 'Read all data from the htm file into RangetoHTML Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.ReadAll ts.Close RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=") 'Close TempWB TempWB.Close savechanges:=False 'Delete the htm file we used in this function Kill TempFile Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function 

我的电子邮件正文理论上应该像 – http://imgur.com/45Yic3Q任何帮助将不胜感激

NB我目前正在使用Excel 2007和Outlook 2007。

Answer 1

您必须包括对Outlook对象模型的引用，但它非常简单。 如果你发布了一些代码，会有所帮助，也得到一些点，所以你可以标记你的问题作为回答。

 'vars Dim oApp As Outlook.Application Dim oMail As MailItem Dim wrdEdit 'get running Outlook Application Set oApp = GetObject(, "Outlook.Application") 'create a new email Set oMail = oApp.CreateItem(olMailItem) 'set the subject and recipient oMail.Subject = "Some Subject" oMail.To = "[e-mail]" 'show it oMail.Display 'change to HTML oMail.BodyFormat = olFormatHTML 'get the word editor Set wrdEdit = oApp.ActiveInspector.WordEditor 'get the chart and copy it ActiveSheet.ChartObjects("Chart 1").Copy 'paste it into the email wrdEdit.Application.Selection.Paste 'release objects Set wrdEdit = Nothing Set oMail = Nothing Set oApp = Nothing 

Answer 2

Sorceri的回答并没有直接解决我的问题，虽然这是一个更好的方式发送电子邮件。 我正在寻找使用“CopyPicture方法”的解决scheme。

因此，我将Outlook引用添加到VBE（工具>>参考>> Microsoft Outlook 12.0对象库）。

然后我使用“CopyPicture”方法来获取图片。 把这个拼接成Sorceri的答案，我们可以得到下面的结果。

 'vars Dim oApp As Outlook.Application Dim oMail As MailItem Dim wrdEdit 'get running Outlook Application Set oApp = GetObject(, "Outlook.Application") 'create a new email Set oMail = oApp.CreateItem(olMailItem) 'set the subject and recipient oMail.Subject = "**PUT YOUR SUBJECT HERE**" oMail.To = "**PUT YOUR EMAIL HERE**" 'show it oMail.Display 'change to HTML oMail.BodyFormat = olFormatHTML 'get the word editor Set wrdEdit = oApp.ActiveInspector.WordEditor 'Copy code goes here (send keys) Range("**PUT YOU RANGE HERE**").CopyPicture xlPrinter, xlPicture 'paste it into the email wrdEdit.Application.Selection.Paste oMail.Send 'release objects Set wrdEdit = Nothing Set oMail = Nothing Set oApp = Nothing