Batch email reports in access

Here's code from one of my applications.  It reads a recordset and sends out an email to each company on the list.  The procedure uses two tables to keep track of missing email addresses and errors and empties them out at the start of the procedure.  It also posts status to the form that invokes the procedure.

Private Sub cmdSendEmails_Click()
    Dim strValue As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim qd As DAO.QueryDef
    Dim td As DAO.TableDef
    Dim strMsg As String
    Dim StartTime As Date
    Dim EndTime As Date
    Dim stDocName As String
    Dim QUOTE As String
    Dim DocName As String
    Dim strPath As Variant
    Dim strSQL As String
    Dim CountErr As Integer
    Dim TestEmail As Boolean
    Dim strEmail As String
    
On Error GoTo ErrProc

    QUOTE = """"
    CountErr = 0
    Set db = CurrentDb()
    stDocName = "Inspectors report"
    TestEmail = DLookup("TestEmail", "tblEmail", "RecID = 1")
    
    'get path
    strPath = DLookup("FileFolder", "tblEMail", "RecID = 1")
    If strPath & "" = "" Then
        MsgBox "Please open email defaults form and add document path.", vbOKOnly
        Exit Sub
    End If
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If

    'delete old email errors
    strSQL = "Delete * From tblNoEmailAddress"
    DoCmd.SetWarnings False
    DoCmd.Hourglass True
    DoCmd.RunSQL strSQL
    strSQL = "Delete * From tblEmailErrors"
    DoCmd.RunSQL strSQL
    DoCmd.SetWarnings True
    DoCmd.Hourglass False
    
    'open email error recordset.
    Set td = db.TableDefs!tblNoEmailAddress
    Set rs2 = td.OpenRecordset
    
    
    Set qd = db.QueryDefs!qGetIRDataJobs
    Set rs = qd.OpenRecordset
    
    StartTime = Now()
    Me.lblElapsedTime.Visible = False
    Me.lblStatus.Visible = True
    Me.lblStatus.Caption = "Sending Emails...."
    Me.Recalc
    DoEvents
    DoCmd.Hourglass (True)
    
    ' Create the Outlook session.
        'Set oOL = CreateObject("Outlook.Application")
        'Set oOL = New Outlook.Application
    On Error Resume Next
    Set oOL = GetObject(, "Outlook.Application")

    If Err.Number = 429 Then
        Set oOL = CreateObject("Outlook.application")
    End If

    On Error GoTo ErrProc


    If Me.txtJob & "" = "" Then
        Do Until rs.EOF = True
            Me.txtJob = rs!Job
            GoSub PrintOrEmail
            rs.MoveNext
        Loop
    Else
        GoSub PrintOrEmail
    End If
    'Close outlook session
    Set oOL = Nothing
    
    DoCmd.Hourglass (False)
    DoCmd.SetWarnings (True)
    Me.lblStatus.Caption = "Complete"
    EndTime = Now()
    Me.lblStatus.Visible = True
    Me.lblElapsedTime.Visible = True
    Me.lblElapsedTime.Caption = DateDiff("n", StartTime, EndTime) & " Minutes"
    
    'close recordsets
    rs.Close
    rs2.Close
    If CountErr > 0 Then
        DoCmd.OpenReport "rptNoEmailAddress", acViewPreview
    Else
        MsgBox "All reports were emailed.", vbOKOnly
    End If
    If DCount("*", "tblEMailErrors") > 0 Then
        DoCmd.OpenReport "rptEMailErrors", acViewPreview
    End If
ExitProc:
    Exit Sub
    
PrintOrEmail:
    DocName = strPath & rs!Job & "_" & Format(Date, "yyyymmdd") & ".pdf"
    If rs!IR_Email & "" = "" Then
        DoCmd.OpenReport stDocName, acViewNormal
        rs2.AddNew
            rs2!Job = Me.txtJob
            rs2!PrintDate = Now()
        rs2.Update
        CountErr = CountErr + 1
    Else
        Kill DocName    'delete existing file if any so outputto won't hang
        DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, DocName, False
        ' send the PDF via outlook
        If TestEmail = True Then
            strEmail = "mfalaguerra@safetymarking.net"
        Else
            strEmail = rs!IR_Email
        End If
        
        strValue = Email_Via_Outlook(strEmail, "Quantity Review Report", "", False, DocName)
    End If
    Return
ErrProc:
    Select Case Err.Number
        Case 53 'file not found
            Resume Next
        Case Else
            MsgBox Err.Number & "--" & Err.Description
            Resume Next
    End Select
    
End Sub

Select allOpen in new window

patrickmatthews has a nice article on Automating Outlook from VBA:

https://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_4316-Automate-Outlook-in-VBA-with-the-OutlookCreateItem-Class.html

It's lengthy, but the essential parts for you would be the "Sending Emails" part. You can use this to create your email, and to add Attachments to your emails. Patrick has example code in the article, so I won't go into that, but essentially you include his OutlookCreateItem class in your VBA project, after which you can use that code as needed. There is an Excel and Access example at the end - use the Access demo as your template.

The format for the file name is "XXXX YYYY-MM-DD".pdf with the XXXX being replaced by each traders 4 digit trader number.

So the "XXXX" is from your recordset, but is the YYYY-MM-DD always the "current date" - that is, if I send the email today (12-20-2013) for Trader numer 0099, would I expect to find a PDF named "0099-2103-12-20.pdf"? What happens if I create the reports today, and try to send them tomorrow? Could that happen?

How is your "Trading Groups" table structured? You mention there could be more than one Email address to which a single report would need to be sent. Do you have a separate table that houses those email addresses, and is that table related back to "Trading Groups"? Or do you have multiple Email addresses stored in a single table, like columns named Email1, Email2, etc?

yes the YYYYY-MM-DD is the "current date," the reports will always be sent out the day they are created, and then deleted- the email addresses are in the trading groups tables and you guessed my simplistic method - email1, email2 etc.

Yes the name of the pdf for trader 0099 would be "0099 2103-12-20.pdf"


a picture of my target directory with two files run as a test yesterday, there are actually 50 or so "books" that get a report.

Oops.  I just noticed that I didn't include the email part.  I'll post it tonight if you still need it.  I am at a client site all day and don't have that sample with me.

Without knowing how many of those "Emailxx" fields you have:

Essentially you would loop through the table, and gather the email addresses. For example:

Dim rst As DAO.Recordset
Set rst = Currentdb.OpenRecordset("SELECT * FROM YourTable")

Do While Not rst.EOF
  Dim sEmail as String
  If Nz(rst("Email1"), "") <> "" Then
    sEmail = rst("Email1")
  End If
  If Nz(rst("Email2", "") <> "" Then
    sEmail = sEmail & ";" & rst("Email2")
  End If
  '/ and so on for Email3, Email4, etc
  rst.MoveNext
Loop

sEmail would now contain the semicolon-delimited list of email addresses.

To get the attachment, you'd get the TraderNumber and build up the string:

Dim sFile As String
sFile = "C:\Orders\" & rst("Trader Number") & " " & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & ".pdf"

<now use the OutlookCreateItem class to send the email with the attachment>

Obviously you'd have to change "C:\Orders" to match the path on your system.

Also, you may need to format the Date string in that PDF name, depending on how you actually create the name of the PDF. If you create it using padded values, like 2014-01-01. For Jan. 1, 2014, then you'll need to use that same formatting when locating the attachment.

thanks, that makes me think that I can use more or less the same logic I used to create the file name to pick up the attachment'...

strPathName = CurrentProject.Path & "\orders\" & rs!trader & " " & Format(Now(), "yyyy-mm-dd") & ".pdf"