MS Access VBA 发送带有 PDF 附件的电子邮件

Question

我正在尝试使用我生成的表格和报告将 Access 数据库中的报告导出到多个电子邮件地址。下面是我用来完成此操作的代码。

Function EmailNotification()
On Error GoTo Err_EmailNotification
    Dim olApp As Object
    Dim olMail As Object
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(olMailItem)
    Dim EmailList As String
    Dim EmailList2 As String
    Dim objOutlookRecip As Object
    Dim objOutlookRecip2 As Object
    Dim objOutlookAttach As Object
    Const TERMINAL_QUERY = "SELECT EMail " & _
                          " FROM [EmailList] " & _
                          " ORDER BY Email;"

    Dim dbs As DAO.Database
    Dim rst1 As DAO.Recordset
    DoCmd.OutputTo acOutputReport, "CarryIn_Email", "PDFFormat(*.pdf)", "Q:\2017\Big E Transportation\Accounting\Advanced Auto\Projects Summary Report.PDF", False, " , acExportQualityPrint"
        Set dbs = CurrentDb()
        Set rst1 = dbs.OpenRecordset(TERMINAL_QUERY)
        With rst1
            .MoveFirst
            .MoveLast
            .MoveFirst
            rstX = rst1.RecordCount
            If Not (.EOF And .BOF) Then
                .MoveFirst
                Do Until .EOF
                    Set olApp = CreateObject("Outlook.Application")
                    Set olMail = olApp.CreateItem(olMailItem)
                    With olMail
                        Set objOutlookRecip = .Recipients.Add(rst1!Email)
                        objOutlookRecip.Type = olTo
                        .Subject = "Carry Ins"
                        SETOBJOUTLOOKATTACH = .Attachments.Add("Q:\2017\Big E Transportation\Accounting\Advanced Auto\Projects Summary Report.PDF")
                        .Send
                    End With
                    .MoveNext
                Loop
            End If
        End With

Exit_EmailNotification:
    Exit Function

Err_EmailNotification:
    MsgBox Error$
    Resume Exit_EmailNotification

End Function

我的问题是此代码不是导出带有 PDF 附件的电子邮件，而是导出带有电子邮件作为附件的电子邮件。

我希望此代码导出带有 PDF 附件的电子邮件，而不是带有电子邮件作为附件的电子邮件。

Answer 1

函数是用于计算某些内容并返回结果的过程。你上面的函数没有返回任何东西。

子例程是在进程中执行步骤而不返回结果的过程。

下面提供的代码应该满足您想要完成的目标：

Public Sub EmailNotification()
Dim olApp                           As Object
Dim olMail                          As Object
Dim strExport, strList              As String
Dim rst1                            As DAO.Recordset

Const TERMINAL_QUERY = "SELECT EMail " & _
                       "FROM [EmailList] " & _
                       "ORDER BY Email;"

On Error GoTo ErrorH
'Varibale to update one location for entire code
strExport = "Q:\2017\Big E Transportation\Accounting\Advanced Auto\Projects Summary Report.PDF"
'Ensures strList is empty for below check
strList = Empty
'Outputs the report to PDF using strExport variable
DoCmd.OutputTo acOutputReport, "CarryIn_Email", "PDFFormat(*.pdf)", strExport, False, " , acExportQualityPrint"
'Opens the recordset containing email addresses within const query above
Set rst1 = CurrentDb.OpenRecordset(TERMINAL_QUERY)
'ensure the recordset is fully loaded
rst1.MoveLast
rst1.MoveFirst
'loop to acquire email addresses from query statement, adding ";" to separate each email address
Do While Not rst1.EOF
    If strList = Empty Then
        strList = rst1![Email]
    Else
        strList = strList & "; "
    End If
    rst1.MoveNext
Loop
'Closes recordset and frees object in memory
rst.Close
Set rst = Nothing
'Creates the memory for email objects
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
'Generates email information
With olMail
    'olFormatPlain is easier to type in an email with, my opinion only, this line is not needed
    .BodyFormat = olFormatPlain
    'Who the email is going to, using the strList created during loop above
    .To = strList
    .CC = "" 'Change if you want a CC
    .BCC = "" 'Change is you want a BCC
    .Subject = "Carry Ins"
    .Body = "" 'Change to what ever you want the body of the email to say
    'Attaches the exported file using the variable created at beginning
    .Attachments.Add = strExport
    .Display 'Use for testing purposes only, note out for live runs
    '.Send 'Use for live purposes only, note out for test runs
End With

'Frees email objects stored in memory
Set olMail = Nothing
Set olApp = Nothing

EndCode:
'Ensures all objects are free from memory
If Not rst1 Is Nothing Then
    rst1.Close
    Set rst1 = Nothing
End If
If Not olApp Is Nothing Then
    Set olMail = Nothing
    Set olApp = Nothing
End If
Exit Sub

'Error handler to display error infor in message box, resumes end code
'Change is you want/need this to handle specific error numbers
ErrorH:
MsgBox Err.Number & " - " & Err.Description
Resume EndCode
End Sub