Send emails to Unique users in Range

uphantom88 · Dec 7, 2020

Hi pro.,
I'm working on a access database to manage training course.. I would like to brief the situation as following:
- When open form tracking associate training status , It will automatically send email to [SupervisorEmail]

Access will loop through [SupervisorEmail] and find unique value of supervisor email
For each Supervisor email, access will send email with the rows where that email is present (also including the header)

- To illustrate for my case: we have table [qryEmailSupData] as below

IDassociate	AssociateName	CourseName	Status	ExpiredDate	DirectSupID	SupervisorEmail
Ass001	Felix	General information	Overdue	02-Dec-20	Ass015	Ass015 @ gmail.com
Ass001	Felix	Advance Access	Not yet attended		Ass015	Ass015 @ gmail.com
Ass002	Johnny	General information	Due within 1 month	21-Dec-20	Ass011	Ass011 @ gmail.com
Ass001	Felix	Basic Python	Not yet attended		Ass015	Ass015 @ gmail.com
Ass003	Tom	General information	Overdue	02-Dec-20	Ass001	Ass001 @ gmail.com
Ass002	Johnny	Basic Python	Due within 1 month	25-Dec-20	Ass015	Ass015 @ gmail.com

When I open form/report which show above table, it will send emails to Ass015, Ass011, Ass001 . Example email to Ass015:

Hi Ass015, Please refer below table for your subordinate training status

IDassociate	AssociateName	CourseName	Status	ExipredDate	DirectSupID	SupervisorEmail
Ass001	Felix	General information	Overdue	02-Dec-20	Ass015	Ass015 @ gmail.com
Ass001	Felix	Advance Access	Not yet attended		Ass015	Ass015 @ gmail.com
Ass001	Felix	Basic Python	Not yet attended		Ass015	Ass015 @ gmail.com
Ass002	Johnny	Basic Python	Due within 1 month	25-Dec-20	Ass015	Ass015 @ gmail.com

Thanks & Best regards

As I'm not good at VBA, I intend to approach like this:

Query Unique [SupervisorEmail] from table [qryEmailSupData] and name the query as [QryEmailSup]
Loop through Recordset in [QryEmailSup]
- Loop through Recordset in [qryEmailSupData] with the "WHERE" condition is the current Record of the [qryEmailSup]
- Send email with the content of the filtered table
I did looking around and combine some code on the internet but not successful, my copied & modified code is as following

Rich (BB code):

Public Sub SendSerialEmail()

    Dim olApp As Object
    Dim olItem As Variant
    Dim db As DAO.Database
    Dim rec As DAO.Recordset
    Dim strQryEmailBody As String
    Dim aHead(1 To 7) As String
    Dim aRow(1 To 7) As String
    Dim aBody() As String
    Dim lCnt As Long

    'Create the header row
    aHead(1) = "ID Associate"
    aHead(2) = "Name"
    aHead(3) = "Course Name"
    aHead(4) = "Status"
    aHead(5) = "Expired Date"
    aHead(6) = "DirectSupID"
    aHead(7) = "SupervisorEmail"

    lCnt = 1
    ReDim aBody(1 To lCnt)
    aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"

    
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT DirectSupID, AssociateName, Email FROM qryEmailSup")

    Do Until rs.EOF
            'Create each body row
            strQryEmailBody = "SELECT *, qryEmailSupData.DirectSupID" & vbCrLf & _
            "FROM qryEmailSupData " & vbCrLf & _
            "WHERE (((qryEmailSupData.DirectSupID)=" & rs.Fields("DirecSupID").Value & "));"
            
            Set rec = db.OpenRecordset(strQryEmailBody)
            
            If Not (rec.BOF And rec.EOF) Then
                Do While Not rec.EOF
                    lCnt = lCnt + 1
                    ReDim Preserve aBody(1 To lCnt)
                    aRow(1) = rec("ID Associate")
                    aRow(2) = rec("Name")
                    aRow(3) = rec("Course Name")
                    aRow(4) = rec("Status")
                    aRow(5) = rec("Expired Date")
                    aRow(6) = rec("DirectSupID")
                    aRow(7) = rec("SupervisorEmail")
                    aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
                    
                    rec.MoveNext
                
                Loop
            End If

            aBody(lCnt) = aBody(lCnt) & "</table></body></html>"

            'create the email
            Set olApp = CreateObject("Outlook.application")
            Set olItem = olApp.CreateItem(0)

            olItem.display
            olItem.To = rs.Fields("Email").Value
            olItem.Subject = "Test E-mail"
            olItem.htmlbody = Join(aBody, vbNewLine)
            olItem.display
        
    
        rs.MoveNext
        Loop
    
    rs.Close
    
    Set rs = Nothing
    Set db = Nothing
    


End Sub

Please kindly advise as I encounter "Run-time error '3265' Item not found in this collection" and vba indicate problem at line which I defined strQryEmailBody

arnelgp · Dec 7, 2020

create another Query (qryForTraining):

Code:

SELECT qryEmailSupData.DirectSupID, qryEmailSupData.SupervisorEmail, Count("1") AS Expr1
FROM qryEmailSupData
WHERE (((qryEmailSupData.ExpiredDate) Is Null Or (qryEmailSupData.ExpiredDate)<=DateAdd("m",1,Date())))
GROUP BY qryEmailSupData.DirectSupID, qryEmailSupData.SupervisorEmail;

now this is your code that include qryForTraining:

Code:

Public Sub SendSerialEmail()

    Dim olApp As Object
    Dim olItem As Variant
    Dim db As DAO.Database
    Dim rs1 As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim strQryEmailBody As String
    Dim aHead(1 To 7) As String
    Dim aRow(1 To 7) As String
    Dim aBody As String
    Dim lCnt As Long


    'Create the header row
    aHead(1) = "ID Associate"
    aHead(2) = "Name"
    aHead(3) = "Course Name"
    aHead(4) = "Status"
    aHead(5) = "Expired Date"
    aHead(6) = "DirectSupID"
    aHead(7) = "SupervisorEmail"

     
    lCnt = 1
 
    Set db = CurrentDb
    Set rs1 = db.OpenRecordset("Select * From qryForTraining Where Expr1 > 0;")
    If Not (rs1.BOF And rs1.EOF) Then
        rs1.MoveFirst
    End If
    Do Until rs1.EOF
 
        Set rs2 = db.OpenRecordset("select * from qryEmailSupData where " & _
                "((ExpiredDate Is Null) Or (ExpiredDate <= " & Format(DateAdd("m", 1, Date), "\#mm\/dd\/yyyy\#") & ")) And " & _
                "(DirectSupID = '" & _
                rs1!DirectSupID & "');")
        rs2.MoveFirst

        lCnt = 0
        aBody = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
        Do Until rs2.EOF
         
            'Create each body row
                    lCnt = lCnt + 1
                    aRow(1) = rs2("IDAssociate")
                    aRow(2) = rs2("AssociateName")
                    aRow(3) = rs2("CourseName")
                    aRow(4) = rs2("Status")
                    aRow(5) = rs2("ExpiredDate") & vbNullString
                    aRow(6) = rs2("DirectSupID")
                    aRow(7) = rs2("SupervisorEmail")
                    aBody = aBody & "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
                 
                    rs2.MoveNext
             
        Loop
        rs2.Close
        Set rs2 = Nothing
     
        aBody = aBody & "</table></body></html>"

        'create the email
        Set olApp = CreateObject("Outlook.application")
        Set olItem = olApp.CreateItem(0)

        With olItem
            .To = rs1("SupervisorEmail").Value
            .Subject = "Test E-mail"
            .htmlbody = aBody
            .display
        End With
     
 
        rs1.MoveNext
    Loop
 
    rs1.Close
    Set rs1 = Nothing
    Set db = Nothing
 


End Sub

the code based on your current data, will generate 3 email.

uphantom88 · Dec 7, 2020

Hi arnelgp,
Thank you very much for your instruction, I did apply your code, however, an error poped up as below pictures

And in the VBA table, it indicated that there something wrong with rs2 SQL code i

uphantom88 · Dec 7, 2020

Hi arnelgp,
I did modify the highlight code a little bit and got it working.

Thank you very much for your advice.

Below is the code for those who want to refer in case they have the same demand:

Code:

Public Sub SendSerialEmail()

    Dim olApp As Object
    Dim olItem As Variant
    Dim db As DAO.Database
    Dim rs1 As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim strQryEmailBody As String
    Dim aHead(1 To 5) As String
    Dim aRow(1 To 5) As String
    Dim aBody As String
    Dim lCnt As Long


    'Create the header row
    aHead(1) = "ID Associate"
    aHead(2) = "Name"
    aHead(3) = "Course Name"
    aHead(4) = "Status"
    aHead(5) = "Expired Date"
        
    lCnt = 1
    
    Set db = CurrentDb
    Set rs1 = db.OpenRecordset("qryForTraining")
    If Not (rs1.BOF And rs1.EOF) Then
        rs1.MoveFirst
    End If
    Do Until rs1.EOF
        strQryEmailBody = "SELECT * FROM qryEmailSupData " & "WHERE (((qryEmailSupData.DirectSupID)=" & rs1("DirectSupID") & "));"
        Set rs2 = db.OpenRecordset(strQryEmailBody)
        
        rs2.MoveFirst

        lCnt = 0
        aBody = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
        Do Until rs2.EOF
            
            'Create each body row
                    lCnt = lCnt + 1
                    aRow(1) = rs2("IDAssociate")
                    aRow(2) = rs2("AssociateName")
                    aRow(3) = rs2("CourseName")
                    aRow(4) = rs2("Status")
                    aRow(5) = rs2("ExpiredDate") & vbNullString
                    aBody = aBody & "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
                    
                    rs2.MoveNext
                
        Loop
        rs2.Close
        Set rs2 = Nothing
        
        aBody = aBody & "</table></body></html>"

        'create the email
        Set olApp = CreateObject("Outlook.application")
        Set olItem = olApp.CreateItem(0)

        With olItem
            .To = rs1("SupervisorEmail").Value
            .Subject = "Test E-mail"
            .htmlbody = aBody
            .display
        End With
        
    
        rs1.MoveNext
    Loop
    
    rs1.Close
    Set rs1 = Nothing
    Set db = Nothing
    


End Sub

arnelgp · Dec 7, 2020

so DirectSupID is using Lookup!

i updated my code, so change this:

Set rs1 = db.OpenRecordset("qryForTraining")

To:

Set rs1 = db.OpenRecordset("select * qryForTraining where [expr1] > 0;")

so only those supv where their subordinate has not undergone training or will expire within a month will be included.

Donnie1ben · Aug 20, 2022

Hi @arnelgp. I have same situation and want to implement same using the code suggestion. However I keep encountering error on this line "Set rs2 = db.OpenRecordset(strQryEmailBody)". It appears nothing is parsed to this recordset. My modifications do not also work.

Send emails to Unique users in Range

uphantom88

New member

arnelgp

..forever waiting... waiting for jellybean!

uphantom88

New member

uphantom88

New member

arnelgp

..forever waiting... waiting for jellybean!

Donnie1ben

New member

Similar threads

Users who are viewing this thread