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

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?
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
SteveL13Author Commented:
Pat, I think I can work with this.  Thanks much.
You're welcome
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.