将数据透视表复制到 Outlook，然后发送答案

【问题标题】：Copy Pivot Table to Outlook then Send将数据透视表复制到 Outlook，然后发送
【发布时间】：2021-09-17 02:46:40
【问题描述】：

我需要有关如何将数据透视表添加到我的电子邮件正文的帮助。这是我当前的代码。

Sub EmailSend()

    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)
    
    olMail.To = "c_dpal###in@###.com.##"
    olMail.CC = "c_dpal###in@###.com.##"
    olMail.Subject = Workbooks("### Report").Sheets("####Perf").Range("J3")
    olMail.Body = "Good Day Ms ###," & vbCrLf & vbCrLf & "Please see performance as of today:" & vbCrLf & vbCrLf & "Regards," & vbCrLf & "####"
    olMail.Send

End Sub

目前，我不知道该怎么做，而且我似乎无法在网上找到如何做。感谢您的大力帮助。谢谢！

【问题讨论】：

好的，这是一个有趣的问题。可能最简单的 (?) 方法是将透视表呈现为 HTML 表，然后将其插入 MailItem 对象的正文中。（我假设您的 MailItem 对象自动支持 HTML：如果不是，那是另一件事，您必须弄清楚如何实现。）
您粘贴的这段代码来自电子表格中的 VBA 宏，对吗？我假设您的数据透视表已经存在于电子表格中。
是的，安，正确。谢谢！将研究你提到的这个解决方案。谢谢你，安！
我不知道它是否可以通过编程方式完成，但是由于您可以将 Excel 范围复制并粘贴到其他文档中，并且它们的行为类似于 HTML 表格，因此应该可以复制范围并将其转换为 HTML。我不知道你会在哪里寻找该功能，但它应该在某个地方！
祝你好运！ ??????

标签： excel vba pivot-table

【解决方案1】：

我曾经使用过 Ron de Bruin 的 RangeToHTML，效果很好。

将此代码放在标准模块上并尝试一下。我使用了两个范围，一个用于枢轴过滤器，另一个用于枢轴体

Sub EmailSend()

    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application

    Dim olEmail As Outlook.MailItem
    Set olEmail = olApp.CreateItem(olMailItem)
    
    With olEmail
        ' Recipients
        .To = "c_dpal###in@###.com.##"
        .CC = "c_dpal###in@###.com.##"
        
        ' Subject
        .Subject = ActiveWorkbook.Sheets("Sheet1").Range("J3")
        
        ' Mail body
        .BodyFormat = olFormatHTML
        .display                        ' display comes here so that the signature can be shown if it exists
        
        Dim strBody As String
        Dim PivotRng As Range
        Dim PivotFilterRng As Range: Set PivotFilterRng = ActiveSheet.Range("B4:C6")
        
        ' Greetings
        strBody = strBody & "Good Day Ms ###," & "<br><br>"
        strBody = strBody & "Please see performance as of today:" & "<br><br>"
        
        ' Pivot Filters
        strBody = strBody & RangetoHTML(PivotFilterRng)
        
        ' Pivot body
        Set PivotRng = ActiveSheet.PivotTables(1).TableRange1
        strBody = strBody & RangetoHTML(PivotRng) & "<br>"
        strBody = strBody & "Regards," & "<br>" & "####"
        
        ' Insert 'strBody'
        .HTMLBody = strBody & .HTMLBody
        
        ' Send mail
        '.send
    End With
End Sub

Ron de Bruin 函数

Function RangetoHTML(Rng As Range)
    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"

    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

    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

    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=")

    TempWB.Close SaveChanges:=False

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

【讨论】：