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

Question

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

我已经编写了一大段 VBA 来自动执行此报告，现在我正处于希望通过电子邮件自动发送此报告的位置。我尝试查看http://www.rondebruin.nl/，这似乎是从 Excel 发送电子邮件的正常第一个呼叫端口，但是我似乎找不到我要找的东西。

我试图复制的功能是

• 复制范围("H5:N100")
• 在 Outlook 中创建主题为“X”的新电子邮件
• 选择性粘贴（增强元文件或位图通常会产生最佳效果）
• 向收件人“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 = "EMAIL@DOMAIN.COM"
        .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 任何帮助将不胜感激

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

Answer 1

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

因此，我添加了对 VBE 的 Outlook 引用（工具 >> 参考 >> 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

Answer 2

您必须包含对 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 = "Someone@somewhere.com"
'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