Access Diva Looping Records to Send eMail

Looping Records to Send eMail...

Two days in a row with questions about looping reports to send eMail... yep, time to post. Below are two different methods. The Excel one just drops the data to an Excel workbook while the second one uses an existing report to save and send PDF.

For both just copy into a Module (not behind a Form) and save remembering not to use the Function name as the name of the Module. Then just adjust the path, report, table and field information and you're good to go.

The difficult I do immediately, the impossible takes a little bit longer.

Option Compare Database
Option Explicit
 
Public olApp As Object
Public olNameSpace As Object
Public objRecipients As Object
Public objNewMail As Object 'Outlook.MailItem
Function InitializeOutlook() As Boolean
' This function is used to initialize the global Application and
' NameSpace variables.
 
    On Error GoTo Init_Err
    Set olApp = CreateObject("Outlook.Application", "LocalHost")  ' Application object
    Set olNameSpace = olApp.GetNamespace("MAPI")  ' Namespace object
    Set objNewMail = olApp.CreateItem(0)
    InitializeOutlook = True
Init_Bye:
 
    Exit Function
Init_Err:
    InitializeOutlook = False
    Resume Init_Bye
 
End Function
Function fSendeMailExcel() As String
On Error GoTo Error_Proc
 
    DoCmd.Hourglass True
    'Set global Application and NameSpace object variables, if necessary.
    If olApp Is Nothing Then
        If InitializeOutlook = False Then
            MsgBox "Unable to initialize Microsoft Outlook!"
        End If
    End If
 
    'Create new MailItem object.
    Set objNewMail = olApp.CreateItem(0)
 
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim v As String
    Dim strAttachments As String
    Dim strQry As String
    Dim qdfTemp As DAO.QueryDef
    Dim strSQL As String
 
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("SELECT apAssociateID, apemailAddress From tblAssociateProfile")
    'Identify a query for TransferSpreadsheet
    strSQL = "qryTemp"
 
    With rs
        .MoveFirst
            Do While Not .EOF
                v = rs.Fields(0).Value
                strQry = "SELECT aActivityID, aNotes FROM tblActivities WHERE aCompleted=False AND aAssociateID= " & v & ""
 
        Set qdfTemp = CurrentDb.CreateQueryDef(strSQL, strQry)
        qdfTemp.Close
        Set qdfTemp = Nothing
                'Send out the Spreadsheet
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, strSQL, "C:\Hold\" & v & ".xlsx", True
                'Identify the Spreadsheets for individual eMails
                strAttachments = "C:\Hold\" & rs!apAssociateID & ".xlsx"
 
        Set objNewMail = olApp.CreateItem(0)
        With objNewMail
            .To = rs.Fields("apemailAddress")
            .Subject = "Your message here"
            .Body = "See attachment..."
                If strAttachments <> "" Then
                    .Attachments.Add strAttachments
                End If
            .Send
        End With
        .MoveNext
        'Clean up query because it will not overwrite without asking
        CurrentDb.QueryDefs.Delete strSQL
    Loop
    End With
        rs.Close
        Set rs = Nothing
 
Exit_Proc:
    DoCmd.Hourglass False
    Exit Function
Error_Proc:
    Select Case Err.Number
        Case 287:
          'On Error Resume Next
          Resume Exit_Proc 'ignore the error'
        Case Else:
          MsgBox "Error encountered fSendeMail: " & Err.Description
          Resume Exit_Proc 'display a message then exit'
    End Select
 
End Function

VBA

Tips (Main)

Home

Excel

PDF

Option Compare Database
Option Explicit
 
Public olApp As Object
Public olNameSpace As Object
Public objRecipients As Object
Public objNewMail As Object 'Outlook.MailItem
Function InitializeOutlook() As Boolean
' This function is used to initialize the global Application and
' NameSpace variables.
 
    On Error GoTo Init_Err
    Set olApp = CreateObject("Outlook.Application", "LocalHost")  ' Application object
    Set olNameSpace = olApp.GetNamespace("MAPI")  ' Namespace object
    Set objNewMail = olApp.CreateItem(0)
    InitializeOutlook = True
Init_Bye:
 
    Exit Function
Init_Err:
    InitializeOutlook = False
    Resume Init_Bye
 
End Function
Public Function feMailToPDF() As String
On Error GoTo Error_Proc
 
    DoCmd.Hourglass True
 
    'Set global Application and NameSpace object variables, if necessary.
    If olApp Is Nothing Then
        If InitializeOutlook = False Then
            MsgBox "Unable to initialize Microsoft Outlook!"
        End If
    End If
 
    'Create new MailItem object.
    Set objNewMail = olApp.CreateItem(0)
 
    Dim strTo As String
    Dim strSQL As String
    Dim rs As DAO.Recordset
    Dim strSubject As String
    Dim strBody As String
    Dim strAttachments As String
 
        strSQL = "SELECT NotifeeID, apCompanyeMailAddress " & _
                    "FROM qryeMailOverdueReportNotifee " & _
                        "GROUP BY NotifeeID, apCompanyeMailAddress"
 
        Set rs = CurrentDb.OpenRecordset(strSQL)
 
        With rs
            .MoveFirst
                Do While Not .EOF
                    DoCmd.OpenReport "rpteMailOverdueNotifee", acViewPreview, , "[NotifeeID] = " & rs!NotifeeID
                    DoCmd.Minimize
                    DoCmd.OutputTo acOutputReport, "rpteMailOverdueNotifee", acFormatPDF, "H:\Databases\Reports\" & !NotifeeID & "-Overdue.pdf"
                    DoCmd.Close acReport, "rpteMailOverdueNotifee", acSaveNo
            strAttachments = "C:\Databases\Reports\" & !NotifeeID & "-Overdue.pdf"
 
            Set objNewMail = olApp.CreateItem(0)
            With objNewMail
                .To = rs.Fields("apCompanyeMailAddress")
                .Subject = "Overdue!"
                .Body = "See attachment..."
                    If strAttachments <> "" Then
                        .Attachments.Add strAttachments
                    End If
                .Send
            End With
            .MoveNext
            Loop
                'Add to keep folder empty
                If Dir("C:\Databases\Reports\*.pdf") <> "" Then
                    Kill "C:\Databases\Reports\*.pdf"
                End If
            End With
 
            rs.Close
            Set rs = Nothing
 
Exit_Proc:
    DoCmd.Hourglass False
    Exit Function
Error_Proc:
    Select Case Err.Number
        Case 287:
          Resume Exit_Proc 'ignore the error'
        Case Else:
          MsgBox "Error encountered feMailToPDF: " & Err.Description
          Resume Exit_Proc 'display a message then exit'
    End Select
 
End Function