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

我有一份每天生成的报告。此报表包含约7个图表、1个表格（仅为excel单元格的正常组）和许多用于格式化的合并单元格

我已经编写了一个很好的VBA来自动生成这份报告，现在我正准备自动通过电子邮件发送这份报告。我试图寻找似乎是正常的正常第一端口的电子邮件从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

理论上，我的电子邮件正文应该是- 任何帮助都将不胜感激

---

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

您必须包含对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

---

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

因此，我将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

---

在将图表图像插入电子邮件正文之前，请尝试导出图表图像。此外，包含一些代码将使我们更好地了解错误所在。我将尝试将其添加到代码中，尽管我假设需要添加更多以正确显示合并的单元格和格式。