将excel自动过滤表复制到vba中的Outlook电子邮件

Question

我正在尝试使用 Ron de Bruin 著名的 RangetoHTML 函数 将 excel 过滤表复制到电子邮件，我的原始代码 使用 for 循环根据我创建的列表自动过滤表 并尝试将此过滤后的表格复制到我希望发送的每个电子邮件地址，但是 emailbody 的内容始终是“？” 不知道有没有人可以帮我看看代码有什么问题？

Sub create_email_table()

Dim count_col As Integer
Dim count_row As Integer
Dim og As Worksheet
Dim list As Worksheet
Dim ism As String
Dim i As Long
Dim rng As Range

Set og = Worksheets("ISM") 'the full sheet
Set list = Worksheets("ISM Email") 'the list I use to filter the datasheet


og.Activate

count_col = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
count_row = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))


list.Activate
Count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))


For i = 1 To Count

'updating the team
ism = list.Cells(i, 1).Text

og.AutoFilterMode = False      'turn off prior filters

og.Range("A1:E1").AutoFilter Field:=5, Criteria1:=ism

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = og.Range("A1:B1").SpecialCells(xlCellTypeVisible)


If rng 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


Dim dam As Object
  
    Set dam = CreateObject("outlook.application").createitem(0)
    dam.To = list.Cells(i, 1).Value
    dam.Subject = "Reminder of no record in system "
    dam.HTMLbody = RangetoHTML(rng)
    dam.Display
Next i

Application.CutCopyMode = False
og.ShowAllData
og.AutoFilterMode = False

End Sub

上面是我的 for 循环，用于自动过滤工作表并向每个收件人发送过滤后的表格，下面是 RangeTohtml 函数

Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    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

Answer 1

我不确定为什么 RangetoHTML 在这种情况下不起作用...但我的猜测是它与 AutoFiltered 表的可见单元格是一个不连续的范围有关。

我建议使用 Word 对象模型将过滤后的表格复制粘贴到 Outlook 邮件项目中。这是一个可以为您执行此操作的函数：

Public Function ExcelRangeToOutlookEmailBody(Rng As Range) As Object
    Dim Wb As Workbook, Sh As Worksheet
    Dim OlkApp As Object, OlkMsg As Object, OlkInsp As Object
    Dim WordDoc As Object
   
    Set Sh = Rng.Parent
    Set Wb = Sh.Parent
    Rng.Copy
   
    Set OlkApp = CreateObject("Outlook.Application")
    Set OlkMsg = OlkApp.CreateItem(0)
    Set OlkInsp = OlkMsg.GetInspector
   
    If OlkInsp.EditorType = 4 Then
        Set WordDoc = OlkInsp.WordEditor
        WordDoc.Content.PasteAndFormat 16
    End If
   
    Application.CutCopyMode = False
    Set ExcelRangeToOutlookEmailBody = OlkMsg
    Set OlkApp = Nothing
End Function

参数Rng 是您要插入到电子邮件中的单元格范围。该函数返回 Outlook MailItem 对象，单元格已粘贴到其主体中。调用它并将返回值保存在对象中，对电子邮件执行其他操作，例如设置收件人/主题字段、显示或发送。

使用 Word 对象模型将 Excel 单元格复制到 Outlook 中非常“所见即所得”。这有很多优点。如果您复制整个自动过滤范围，它只会粘贴可见值 - 无需专门选择它们。它甚至会粘贴选择区域中的任何图片、图表或其他形状！

以下是关于如何将此函数用于特定任务的一般概念：

Sub MakeEmailForEachAutoFilterValue()
    Dim DataWorksheet As Worksheet
    Dim FilterWorksheet As Worksheet
    Dim FilterColumn As Long
    Dim FilterCell As Range
    Dim OutlookMsg As Object
   
    Set DataWorksheet = Worksheets("ISM")
    Set FilterWorksheet = Worksheets("ISM Email")
    FilterColumn = 5
   
    For Each FilterCell In FilterWorksheet.UsedRange.Columns(1).Cells
        DataWorksheet.UsedRange.AutoFilter Field:=FilterColumn, Criteria1:=FilterCell.Value
        Set OutlookMsg = ExcelRangeToOutlookEmailBody(DataWorksheet.UsedRange)
        OutlookMsg.Subject = "Reminder of no record in system"
        OutlookMsg.Display
    Next FilterCell
End Sub

上面的 Sub 将遍历“ISM 电子邮件”第一列中的每个单元格，将该单元格的值应用为“ISM”的 E 列（即 5）上的自动过滤器，并生成一封带有表格的新电子邮件正文中的自动过滤数据。