宏到电子邮件工作表，作为包含对象而不仅仅是单元格的正文吗? [英] Macro to email sheet as the body that includes objects not just cells?

问题描述

我正在尝试创建一个Excel宏，该宏将通过电子邮件正文发送包含数据表，图表和图像的电子邮件.到目前为止，我在下面显示了宏显示，但是它只会复制单元格上的内容，而不会复制任何对象.我还不太了解如何更改它以复制对象，因此我不得不根据我在网上找到的内容以及对C ++的了解(我几年前唯一学习过的语言)将这些内容拼凑起来.宏的要点是，它可以通过电子邮件将每个人的信息发送给每个人，并提供他们可以遵循的简单图表.有人可以修复或建议我如何修复此宏，以便电子邮件的正文可以显示图表和图像，谢谢.

总共有5个对象通过电子邮件发送:图片10"，文本框8"，图片9"，图片6"，图表5"
P.S. {OutMail .To = Range("N3").Value}是一个伪值，因此我不会在处理宏时错误地发送任何内容.
代码:

Hi,

I am trying to create a excel macro that will send out emails with a data table, chart, and images all in the body of the email. So far I have the macro show below, but it will only copy over the cells not any of the objects. I don’t know enough to change it to copy over the objects as well I have had to piece-meal this together from what I have found online and my knowledge of C++ (the only language I have ever learned years ago). The point of the macro is so that it emails each person their information and have an easy chart they can follow. Could someone please fix or advise me how to fix this macro so that the body of the email would show the chart and images, Thanks.

there are 5 objects in all to be emailed: "Picture 10", "Text Box 8", "Picture 9", "Picture 6", "Chart 5"
P.S. the {OutMail .To = Range("N3").Value} is a dummy value so that i dont send anything out by mistake wile working on the macro.
Code:

Sub Info()
'
' Info Macro
' Macro recorded 5/13/2011 by NV
'
' Keyboard Shortcut: Ctrl+c
'
    Dim i As Integer
    
    NumRows = Sheets("Data Chart").Range("D5", Sheets("Data Chart").Range("D5").End(xlDown)).Rows.Count
    For i = 0 To NumRows
     If Not IsEmpty(Sheets("Data Chart").Range("D5")) Then
        Sheets("Input").Select
        Range("J2").Select
        ActiveCell.Value = Sheets("calc").Range("P2").Offset(i, 0).Value
        Range("K2").Select
        ActiveCell.Value = Sheets("calc").Range("Q2").Offset(i, 0).Value
        Range("B7").Select
        ActiveCell.Value = Sheets("calc").Range("R2").Offset(i, 0).Value
        Range("J3").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 0).Value
        Range("B10").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 4).Value
        Range("B11").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 5).Value
        Range("B12").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 6).Value
        Range("B13").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 7).Value
        Range("B14").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 8).Value
        Range("B15").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 9).Value
        Range("B16").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 10).Value
        Range("B17").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 11).Value
        Range("B18").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 12).Value
        Range("B19").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 13).Value
        Range("B20").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 14).Value
        Range("B21").Select
        ActiveCell.Value = Sheets("calc").Range("O2").Offset(i, 15).Value
        
    
  
' Email section
        Dim rng As Range
        Dim OutApp As Object
        Dim OutMail As Object
        With Application
          .EnableEvents = False
          .ScreenUpdating = False
        End With
     
        Set rng = Nothing
        Set rng = Sheets("Graph").UsedRange
        'You can also use a sheet name
        'Set rng = Sheets("YourSheet").UsedRange
      
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
     
        On Error Resume Next
        With OutMail
          .To = Range("N3").Value
          .CC = ""
          .BCC = ""
          .Subject = "This is the Subject line"
          .HTMLBody = RangetoHTML(rng)
          .Display   'or use  .Send
        End With
        On Error GoTo 0
     
        With Application
          .EnableEvents = True
          .ScreenUpdating = True
        End With
     
        Set OutMail = Nothing
        Set OutApp = Nothing
      End If
    Next
End Sub
Function RangetoHTML(rng 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)
    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
 
    '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

推荐答案

(" )& " &格式(现在，" )& " ' 复制范围并创建一个新工作簿以将数据粘贴到 复制 设置 TempWB = Workbooks.Add( 1 ) 使用 TempWB.Sheets( 1 ) .Cells( 1 ).PasteSpecial Paste:= 8 .Cells( 1 ).PasteSpecial xlPasteValues，，错误，错误 .Cells( 1 ).PasteSpecial xlPasteFormats，错误，错误 .Cells( 1 ).选择 Application.CutCopyMode = 错误 打开 错误 恢复 真 .DrawingObjects.Delete 打开 错误 转到 结束 使用 ' 将工作表发布到htm文件 使用 TempWB.PublishObjects.Add(_ SourceType:= xlSourceRange，_ 档名:= TempFile，_ 工作表:= TempWB.Sheets( 1 ).名称，_ 来源:= TempWB.Sheets( 1 ).UsedRange.Address，_ HtmlType:= xlHtmlStatic) .publish(真) 结束 使用 ' 将htm文件中的所有数据读取到RangetoHTML 设置 fso = CreateObject(" 跨度>) 设置 ts = fso.GetFile(TempFile).OpenAsTextStream( 1 ，-2) RangetoHTML = ts.ReadAll ts.Close RangetoHTML = Replace(RangetoHTML，" ，_ " ) ' 关闭TempWB TempWB.Close savechanges:= False ' 删除我们在此功能中使用的htm文件 杀死TempFile 设置 ts = 什么都没有 设置 fso = 什么都没有 设置 TempWB = 什么都没有 结束 功能

("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) 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 '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

如果要开发通过创建自己的宏以从MS Excel发送电子邮件的MS Outlook应用程序，您应该下载 Microsoft Office Outlook 2003 VBA语言参考帮助文件 [ ^ ]

在那里，您找到了将工作簿添加为附件的方法(MS示例):

If you want to develop MS Outlook application by creating own macro to send emails from MS Excel, you should download Microsoft Office Outlook 2003 VBA Language Reference help file[^]

There you find method to add workbook as attachment (MS example):

Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
myAttachments.Add "C:\My Documents\Q496.xls", olByValue, 1, "4th Quarter 1996 Results Chart"

我建议您使代码更专业:
1)代码上下文(！)，
2)使用对象变量，毕竟-清除它们使用的内存，
3)使用错误处理程序.
例如:

I suggest you to make code more professional:
1) Context of code (!),
2) Use Object variables and after all - clear memory used by them,
3) Use error handlers.
For example:

Option Explicit

Sub CreateMails()
Dim wshInput As Worksheet, wshData As Worksheet, wshCalc As Worksheet, rng As Range
Dim i As Integer, numRows As Integer
Dim sTo As String, sSubject As String, sHTMLBody As String
    
On Error GoTo Err_CreateMails

'do not show what macro do
Application.ScreenUpdating = False

'set object variables
Set wshInput = ThisWorkbook.Worksheets("Input")
Set wshData = ThisWorkbook.Worksheets("Data Chart")
Set wshCalc = ThisWorkbook.Worksheets("calc")

'get count of rows
numRows = wshData.Range("D5", wshData.Range("D5").End(xlDown)).Rows.Count
For i = 0 To numRows
    If Not IsEmpty(wshData.Range("D5")) Then
        wshInput.Range("J2").Value = wshCalc.Range("P2").Offset(i, 0).Value
        wshInput.Range("K2").Value = wshCalc.Range("Q2").Offset(i, 0).Value
        wshInput.Range("B7").Value = wshCalc.Range("R2").Offset(i, 0).Value
        wshInput.Range("J3").Value = wshCalc.Range("O2").Offset(i, 0).Value
        wshInput.Range("B10:B21").Copy
        wshCalc.Range("O2").Offset(i, 4).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        sTo = wshInput.Range("N3")
        sSubject = "This is the Subject line"
        Set rng = ThisWorkbook.Worksheets("Graph").UsedRange
        sHTMLBody = RangetoHTML(rng)
        If Not CreateMailItem(sTo, sSubject, sHTMLBody) Is Nothing Then
            'success!
        Else
            'error!
        End If
    End If
Next

Exit_CreateMails:
    On Error Resume Next
    Application.ScreenUpdating = True
    Set wshInput = Nothing
    Set wshData = Nothing
    Set wshCalc = Nothing
    Exit Sub

Err_CreateMails:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_CreateMails
End Sub

Function CreateMailItem(sTo As String, sSubject As String, sHTMLBody As String) As Object
Dim OutApp As Object, OutMail As Object

On Error GoTo Err_CreateMailItem

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
  .To = sTo
  ''.CC = ""
  ''.BCC = ""
  .Subject = sSubject
  .HTMLBody = sHTMLBody
  .Display
End With

Exit_CreateMailItem:
    On Error Resume Next
    CreateMailItem = OutMail
    Set OutMail = Nothing
    Set OutApp = Nothing
    Exit Function

Err_CreateMailItem:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_CreateMailItem

End Function

这篇关于宏到电子邮件工作表，作为包含对象而不仅仅是单元格的正文吗?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！