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

VBA: emailing a range and an image

提问by Z471

I have a report that I generate daily. This report contains about 7 charts, 1 table (just normal group of excel cells) and a number of merged cells for formatting.

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

I have written a nice chunk of VBA to automate this report and now I am at the bit where I wish to email this report automatically. I attempted looking on http://www.rondebruin.nl/which seems to be normal the normal first port of call for emailing from Excel, however I can't seem to find what I am looking for.

我已经写了一大段 VBA 来自动化这个报告，现在我想自动发送这个报告。我尝试在http://www.rondebruin.nl/上查找，这似乎是从 Excel 发送电子邮件的正常第一个正常调用端口，但是我似乎无法找到我正在寻找的内容。

The functionality I am trying to replicate is

我试图复制的功能是

• Copy range("H5:N100")
• Create new email in outlook with subject "X"
• Paste Special (Enchance Meta file or Bitmap generally gives best results)
• Send email to recipient "Y"

• 复制范围("H5:N100")
• 在 Outlook 中创建主题为“X”的新电子邮件
• 特殊粘贴（增强元文件或位图通常会提供最佳效果）
• 向收件人“Y”发送电子邮件

My problem is that I do not wish to attach the file and I need the charts. When converting to html i seem to lose the charts and the oddly the gradients in certain merged cells are lost.

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

EDIT: As requested the code I'm currently using

编辑：根据要求，我目前使用的代码

    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 = "[email protected]"
        .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

My email body should in theory look like - http://imgur.com/45Yic3QAny help would be greatly appreciated

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

N.B. I am currently using Excel 2007 and Outlook 2007.

注意我目前使用 Excel 2007 和 Outlook 2007。

回答by Z471

Sorceri's answer didn't directly solve my issue although it was a neater way of sending the email. The solution which i was looking for using the "CopyPicture method.

Sorceri 的回答并没有直接解决我的问题，尽管它是一种更简洁的电子邮件发送方式。我正在寻找使用“CopyPicture 方法”的解决方案。

As such I added the Outlook reference to VBE (Tools >> References >> Microsoft Outlook 12.0 Object Library).

因此，我添加了对 VBE 的 Outlook 参考（工具 >> 参考 >> Microsoft Outlook 12.0 对象库）。

I then used the "CopyPicture" method to get the picture across. Splicing this into Sorceri's answer we get the below.

然后我使用“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

回答by Sorceri

you have to include a reference to the Outlook object model but it is pretty straight forward. Would have helped if you posted some code, also go get some points so you can mark your questions as answered.

您必须包含对 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 = "[email protected]"
'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