Question

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

我写了很多VBA来自动化这个报告，现在我想自动发送这封报告。我试图查看http://www.rondebruin.nl/，这似乎是从Excel发送电子邮件的正常第一个停靠点，但我似乎无法找到我要找的内容。

我想要复制的功能是

复制范围（＆＃34; H5：N100＆＃34;）
使用主题＆＃34; X＆＃34;
选择性粘贴（Enchance元文件或位图通常会产生最佳效果）
向收件人发送电子邮件＆＃34; Y＆＃34;

我的问题是我不想附加文件，我需要图表。当转换为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 任何帮助将不胜感激

N.B。我目前正在使用Excel 2007和Outlook 2007.

Answer 1

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

因此我将Outlook引用添加到VBE（工具＆gt;＆gt;参考＆gt;＆gt; 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

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

2 个答案: