How loop through reports and email those that have an email address to the email recipient

SteveL13 used Ask the Experts™
I have a multi-page report that is grouped by an alpha field.  Each group is a page by itself.  I want to have a command button on a form that when clicked, will email the report to an email recipient on the report.  Some of the reports don't have an email address so that report would have to be skipped.  MS Outlook is the email client.  I don't want to preview the report so it can be hidden.

What would the code look like to accomplish this?
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Distinguished Expert 2017
Here is code from one of my applications.  Generally, you need a query that selects people with data and an email address.  In my case, if there was no email address, the report was printed and mailed.  My code also logs missing email errors.

Private Sub cmdSendEmails_Click()
‘ uses early binding so requires reference to Outlook library
    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...."
    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
        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
    If CountErr > 0 Then
        DoCmd.OpenReport "rptNoEmailAddress", acViewPreview
        MsgBox "All reports were emailed.", vbOKOnly
    End If
    If DCount("*", "tblEMailErrors") > 0 Then
        DoCmd.OpenReport "rptEMailErrors", acViewPreview
    End If
    Exit Sub
    DocName = strPath & rs!Job & "_" & Format(Date, "yyyymmdd") & ".pdf"
    If rs!IR_Email & "" = "" Then
        DoCmd.OpenReport stDocName, acViewNormal
            rs2!Job = Me.txtJob
            rs2!PrintDate = Now()
        CountErr = CountErr + 1
        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 = ""
            strEmail = rs!IR_Email
        End If
        strValue = Email_Via_Outlook(strEmail, "Quantity Review Report", "", False, DocName)
    End If
    Select Case Err.Number
        Case 53 'file not found
            Resume Next
        Case Else
            MsgBox Err.Number & "--" & Err.Description
            Resume Next
    End Select
End Sub

Function Email_Via_Outlook(vAddress, vSubject, vBody, DisplayMsg As Boolean, Optional strFileName)
''''Dim oOL As Outlook.Application
Dim oMailItem As Outlook.MailItem
Dim oRecip As Outlook.Recipient
Dim oAttach As Outlook.Attachment
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim rs As DAO.Recordset
Dim AttPath As String
Dim strSQL As String
On Error GoTo ErrProc
    Set db = CurrentDb()
    Set td = db.TableDefs!tblEmail
    Set rs = td.OpenRecordset
    AttPath = strFileName
'''' Create the Outlook session.
'''Set oOL = CreateObject("Outlook.Application")
' Create the message.
Set oMailItem = oOL.CreateItem(olMailItem)

    ' Add the To recipient(s) to the message.
    Set oRecip = oMailItem.Recipients.Add(vAddress)
    oRecip.Type = olTo
    oMailItem.Subject = vSubject
    oMailItem.body = vBody
'    oMailItem.SendUsingAccount = rs!eMailOnBehalfOf
    ' Add attachments to the message.
    If Not IsMissing(AttPath) And AttPath <> "" Then
        Set oAttach = oMailItem.Attachments.Add(AttPath)
    End If
    ' Resolve each Recipient's name.
    For Each oRecip In oMailItem.Recipients
    ' Should we display the message before sending?
    If DisplayMsg Then
    End If

''''Set oOL = Nothing
    Exit Function

    Select Case Err.Number
        Case Else
            MsgBox Err.Number & "--" & Err.Description
            strSQL = "Insert Into tblEmailErrors (Job, PrintDate, EMail, FileName, ErrNum, ErrDesc) "
            strSQL = strSQL & " Values("
            strSQL = strSQL & QUOTE & Forms!dtepkr!txtJob & QUOTE & ", Now(), " & QUOTE & vAddress & QUOTE & ", " & QUOTE & strFileName & QUOTE
            strSQL = strSQL & ", " & Err.Number & ", " & QUOTE & Err.Description & QUOTE & ");"
            DoCmd.RunMacro "mWarningsOff"
            DoCmd.RunSQL strSQL
            DoCmd.RunMacro "mWarningsOn"
            Resume Next
    End Select
End Function

Open in new window


Pat, I think I can work with this.  Thanks much.
Distinguished Expert 2017

You're welcome

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial