• Status: Solved
  • Priority: High
  • Security: Public
  • Views: 67
  • Last Modified:

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?
0
SteveL13
Asked:
SteveL13
  • 2
1 Solution
 
PatHartmanCommented:
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...."
    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

Function Email_Via_Outlook(vAddress, vSubject, vBody, DisplayMsg As Boolean, Optional strFileName)
    'http://www.access-programmers.co.uk/forums/showthread.php?t=214158
''''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
        oRecip.Resolve
    Next
    ' Should we display the message before sending?
    If DisplayMsg Then
        oMailItem.Display
    Else
        oMailItem.Save
        oMailItem.Send
    End If

''''Set oOL = Nothing
ExitProc:
    Exit Function

ErrProc:
    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

0
 
SteveL13Author Commented:
Pat, I think I can work with this.  Thanks much.
0
 
PatHartmanCommented:
You're welcome
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now