每天从 Excel 向 Outlook 发送电子邮件 - 包括数据透视表 [英] Sending daily email from Excel to Outlook - include PivotTable

问题描述

我正在尝试设置一个宏，该宏只发送一封电子邮件，其中包含位于同一工作表上的两个数据透视表.

I'm trying to set-up a macro that simply sends an email containing two pivot tables that are located on the same sheet.

我当前使用的代码不包括表头.我该如何更改?

The current code I'm using doesn't include the table headers. How can I change this?

旁注:为了每天发送这个，我想我可以将 VBA 代码提取到一个 .vbs 文件中，并在每次打开计算机时运行它.如果 excel 文件位于共享驱动器中，这会起作用吗?

Side Note: To send this daily, I figured I could extract the the VBA code to a .vbs file and have it run everytime the computer is turned on. Would this work if the excel file is located in a share drive?

这是发送到我的电子邮件的内容:

Here's what is being sent to my email:

这是我想要发送的内容:

Here's what I want to be sent:

这是我当前发送电子邮件的代码.

Here's my current code for sending the email.

    'Expired & Warning Updates
'Functions:
' Send daily email with expired and almost-expired digsafes

'Sends email once called
Sub Mail_Selection_Range_Outlook_Body()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection

    Set rng = Sheets("EXPIRED_LIST").Range("A6:F300").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    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

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

    On Error Resume Next
    With OutMail
        .To = "[e-mail]"
        .CC = ""
        .BCC = ""
        .Subject = "Daily Dig-safe Update"
        .HTMLBody = RangetoHTML(rng)
        .Display   'or use .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


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"

    '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

推荐答案

我很笨，没有意识到我的范围偏离了一行.修复了问题.现在是我想办法让它每天发送一封电子邮件的时候了.

I'm stupid and didn't realize my range was off by one row. Fixed the issue. Now it's time for me to figure out how to have it send an email daily.

这篇关于每天从 Excel 向 Outlook 发送电子邮件 - 包括数据透视表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！