VBA代码

Question

以下代码生成邮件以将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

Answer 1

以下是我心爱的懒人日常仪表板中的VBA，我认为这是你想要完成的事情......我之前为类似的情况写了这篇文章，我每天都在使用它3年以上现在。在发送PDF之前，我不知道您是否正在更新文件中的链接，但我将其包括在内以防万一......

您可以在Windows中设置调度程序任务，以便每天在XX：XX时自动打开此文件唯一的要求是计算机已开启且用户已登录或处于锁定屏幕。

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

更新所有工作簿链接
将特定的单元格数据包含在您的电子邮件正文或主题/ / cc / bcc中（我用它来包括我所有的电子邮件样式和html标记）
将文件保存为PDF格式
将文件通过电子邮件发送到指定的电子邮件地址或通讯组
使用新值保存Excel文件

在X时间后关闭Excel文件

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

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

**确保您的Workbook_Open代码符合标准的This.Workbook模块.. **

Workbook_Open包含对其余独立模块功能的调用

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

将Excel =保存到＆gt; 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文件新值

Sub SaveIt() Application.DisplayAlerts = False ChDir "\\NameofDrive\NameofDirectory\FolderName\" 'update to the correct folder ActiveWorkbook.Save 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

将Excel数据添加到邮件中

1 个答案:

VBA代码