MS Access VBA Sending Email with PDF attachement - vba

Question

I am trying to export a report in an from an Access database to multiple email address using a table and a report I have produced. Below is the code I have been using to accomplish this.
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
My problem is that this code is not exporting an email with a PDF attached to it, but instead is exporting an email with an email as the attachment.
I want this code to export an email with a PDF attachment, not an email with an email as the attachment.

Answer 1

Functions are procedures used to calculate something and return a result. The function you have above is not returning anything.
A subroutine is a procedure to run through steps in a process and not return a result.
the code provided below should satisfy what you are trying to accomplish:
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