将Excel数据添加到邮件

以下代码生成邮件以将Excel工作表作为.pdf文档发送

我想使用不同选项卡上实际Excel工作表中的一系列单元格自定义电子邮件正文。所以基本上，我有从Excel表格中提取数字的预写文本，我想用它作为我的自动主体

Sub Email_ActiveSheet_As_PDF()

'Do not forget to change the email ID
'before running this code

Dim OutApp As Object
Dim OutMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.

TempFilePath = Environ$("temp") & "\"

' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.

TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"

'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName

'Now Export the Activesshet as PDF with the given File Name and path

On Error GoTo err
With ActiveSheet
    .ExportAsFixedFormat _
      Type:=xlTypePDF, _
      Filename:=FileFullPath, _
      Quality:=xlQualityStandard, _
      IncludeDocProperties:=True, _
      IgnorePrintAreas:=False, _
      OpenAfterPublish:=False
End With

'Now open a new mail

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

On Error Resume Next
With OutMail
    .To = "michaelbrentklein@gmail.com"
    .Subject = "2014 Pickup Report Now Available"
    .Body = **NEED HELP HERE**
    .Attachments.Add FileFullPath '--- full path of the pdf where it is saved
    .Send   'or use .Display to show you the email before sending it.
    .Display
End With
On Error GoTo 0

'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder

Kill FileFullPath

'set nothing to the objects created
Set OutMail = Nothing
Set OutApp = Nothing

'Now set the application properties back to true
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
MsgBox ("Email has been Sent Successfully")
Exit Sub
err:
    MsgBox err.Description

End Sub

---

这是我心爱的懒人日报仪表板上的VBA，我认为它能实现您的目标。。。不久前我为类似的情况写了这篇文章，现在我每天都在使用它3年多了。我不知道你是否在发送PDF之前更新了文件中的链接，但我把它包括进来只是为了以防万一

您可以在windows中设置计划程序任务，使其每天在XX:XX时间自动打开此文件。唯一的要求是计算机已打开，用户已登录或在锁定的屏幕上

以下是它可以为您提供的功能。

 Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
    ByVal hwnd As Long, _
    ByVal lpText As String, _
    ByVal lpCaption As String, _
    ByVal uType As Long, _
    ByVal wLanguageID As Long, _
    ByVal lngMilliseconds As Long) As Long

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long


Public Sub MsgBoxDelay()
        Const cmsg As String = "This work book will auto-close in 30 seconds.  Click YES to CLOSE FILE, Click NO to KEEP OPEN"
        Const cTitle As String = "This work book will auto-close in 30 seconds.Close the Excel File?"
        Dim retval As Long
        retval = MessageBoxTimeout((FindWindow(vbNullString, Title)), cmsg, cTitle, 4, 0, 60000)

        If retval <> 7 Then
            Call SaveIt
            ThisWorkbook.Close
        End If

    End Sub

更新所有工作簿链接

在电子邮件正文或主题/收件人/抄送/密件抄送中包含特定的单元格数据 （我用它来包括我所有的电子邮件样式和html标记）

将文件保存为PDF格式

通过电子邮件将文件发送到指定的电子邮件地址或通讯组

使用新值保存Excel文件

X时间后关闭Excel文件

    (for the instances where you're not at the computer when this runs)

您可以将每个代码块放在单独的模块中。

 Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
    ByVal hwnd As Long, _
    ByVal lpText As String, _
    ByVal lpCaption As String, _
    ByVal uType As Long, _
    ByVal wLanguageID As Long, _
    ByVal lngMilliseconds As Long) As Long

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long


Public Sub MsgBoxDelay()
        Const cmsg As String = "This work book will auto-close in 30 seconds.  Click YES to CLOSE FILE, Click NO to KEEP OPEN"
        Const cTitle As String = "This work book will auto-close in 30 seconds.Close the Excel File?"
        Dim retval As Long
        retval = MessageBoxTimeout((FindWindow(vbNullString, Title)), cmsg, cTitle, 4, 0, 60000)

        If retval <> 7 Then
            Call SaveIt
            ThisWorkbook.Close
        End If

    End Sub

**确保工作簿\u打开代码位于标准的This.Workbook模块中**

打开的工作簿包含对独立模块其余功能的调用

Option Explicit

Private Sub UpdateLinks()
    Dim Sh As Worksheet
    Dim Links As Variant
    Dim i As Integer
'   Change sheet YourSheetName to suit
    Set Sh = ThisWorkbook.Worksheets("YourSheetName")
    Links = ActiveWorkbook.LinkSources
    If Not IsEmpty(Links) Then
        For i = 1 To UBound(Links)
                                Application.ScreenUpdating = False
                                Application.DisplayAlerts = False
            Workbooks.Open Links(i)
            Sh.Calculate
                    ActiveWorkbook.Close Savechanges:=True
                                Application.ScreenUpdating = True
                                Application.DisplayAlerts = True
        Next i
    End If
End Sub

    Sub SaveIt()
     Application.DisplayAlerts = False
        ChDir "\\NameofDrive\NameofDirectory\FolderName\" 'update to the correct folder
        ActiveWorkbook.Save
     Application.DisplayAlerts = True
    End Sub

VBA代码 查找内联注释和更新值以使其符合您的需要

---

将此代码放入this.Workbook模块中

Private Sub Workbook_Open()
Application.DisplayAlerts = False
With ThisWorkbook
    .UpdateLinks = xlUpdateLinksAlways
End With
Run ("UpdateLinks")
Run ("SavePDF")
Run ("SendEmail")
Run ("SaveIt")
Run ("MsgBoxDelay")
Application.DisplayAlerts = True
End Sub

---

更新所有单元格链接

Option Explicit

Private Sub UpdateLinks()
    Dim Sh As Worksheet
    Dim Links As Variant
    Dim i As Integer
'   Change sheet YourSheetName to suit
    Set Sh = ThisWorkbook.Worksheets("YourSheetName")
    Links = ActiveWorkbook.LinkSources
    If Not IsEmpty(Links) Then
        For i = 1 To UBound(Links)
                                Application.ScreenUpdating = False
                                Application.DisplayAlerts = False
            Workbooks.Open Links(i)
            Sh.Calculate
                    ActiveWorkbook.Close Savechanges:=True
                                Application.ScreenUpdating = True
                                Application.DisplayAlerts = True
        Next i
    End If
End Sub

    Sub SaveIt()
     Application.DisplayAlerts = False
        ChDir "\\NameofDrive\NameofDirectory\FolderName\" 'update to the correct folder
        ActiveWorkbook.Save
     Application.DisplayAlerts = True
    End Sub

---

保存Excel=to>PDF

Sub SavePDF()
            Application.DisplayAlerts = False
'Update this path to match where you would like the PDF to be saved from.
  'NOTE THIS LOCATION AS IT WILL BE USED FOR ATTACHING THE FILE TO SEND VIA EMAIL

    ChDir "\\NameofDrive\NameofDirectory\FolderName\FileName"
    ActiveSheet.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:="\\NameofDrive\NameofDirectory\FolderName\FileName.pdf", _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False  ' Optional open PDF once finished..

            Application.DisplayAlerts = True
End Sub

---

电子邮件模块

Sub SendEmail()
Application.DisplayAlerts = False
Dim OutApp As Object
Dim OutMail As Object
Dim EmailMarkup As String
Dim Send As Boolean
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim headerTxt As String
    headerTxt = Range("n1").Text 'change o1 to the cell you want to reference
Dim bodyTxt As String
    bodyTxt = Range("o1").Text 'change o1 to the cell you want to reference
On Error Resume Next
With OutMail
.To = "" 'put email or distribution group name.
.CC = ""
.BCC = ""

.Subject = "Email Subject"
.EmailMarkup = "<html><header>" & " " & headerTxt & "<header>" & bodyTxt & "</body></html>"
.attachments.Add ("\\NameofDrive\NameofDirectory\FolderName\FileName.pdf")  'add the full file path to your attachment if you want to use this function..

.Send 'or use .Display

End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True

End Sub

---

弹出窗口，以防止计时器用完后文件关闭。将该功能添加到 在指定的时间后保存/关闭Excel，无需用户干预。

 Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
    ByVal hwnd As Long, _
    ByVal lpText As String, _
    ByVal lpCaption As String, _
    ByVal uType As Long, _
    ByVal wLanguageID As Long, _
    ByVal lngMilliseconds As Long) As Long

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long


Public Sub MsgBoxDelay()
        Const cmsg As String = "This work book will auto-close in 30 seconds.  Click YES to CLOSE FILE, Click NO to KEEP OPEN"
        Const cTitle As String = "This work book will auto-close in 30 seconds.Close the Excel File?"
        Dim retval As Long
        retval = MessageBoxTimeout((FindWindow(vbNullString, Title)), cmsg, cTitle, 4, 0, 60000)

        If retval <> 7 Then
            Call SaveIt
            ThisWorkbook.Close
        End If

    End Sub

声明函数MessageBoxTimeout Lib“user32.dll”别名“MessageBoxTimeoutA”（_
再见，只要_
ByVal lpText作为字符串_
ByVal作为字符串_
ByVal uType尽可能长_
ByVal wLanguageID只要_
ByVal lngmills（秒长）一样长
私有声明函数findwindowlib“user32”别名“FindWindowA”（_
ByVal lpClassName作为字符串_
ByVal lpWindowName（作为字符串）长度相同
公共子MsgBoxDelay（）
Const cmsg As String=“此工作簿将在30秒内自动关闭。单击“是”关闭文件，单击“否”保持打开状态”
Const cTitle As String=“此工作簿将在30秒内自动关闭。是否关闭Excel文件？”
暗淡的后退
retval=MessageBoxTimeout（（FindWindow（vbNullString，Title）），cmsg，cTitle，4，0，60000）
如果返回7则
叫SaveIt
此工作簿。关闭
如果结束
端接头

如果电子邮件正文没有格式化，您可以直接将其分配给

.body

。类似于

.Body=Range（“A1”）.Value

。但是，如果希望使用

.HtmlBody

对其进行格式化，则必须以Html标记的格式创建/生成范围值，然后将其直接分配给

.HtmlBody

或在代码内部对其进行操作。下面是你问题的快速答案。。只需使用Range（）从字段中获取文本，然后将文本包装到html标记中，如.EmailMarkup.所示

Dim HeaderText作为字符串HeaderText=Range（“n1”）。Text“将Dim bodyTxt更改为字符串bodyTxt=Range（“o1”）。Text“将EmailMarkup更改为带有OutMail的字符串。EmailMarkup=”“&”“&HeaderText&”“&bodyTxt&”“