Send emails to Unique users in Range (1 Viewer)

uphantom88

New member
Local time
Today, 09:06
Joined
Aug 28, 2020
Messages
4
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

IDassociateAssociateNameCourseNameStatusExpiredDateDirectSupIDSupervisorEmail
Ass001FelixGeneral informationOverdue02-Dec-20Ass015Ass015 @ gmail.com
Ass001FelixAdvance AccessNot yet attendedAss015Ass015 @ gmail.com
Ass002JohnnyGeneral informationDue within 1 month21-Dec-20Ass011Ass011 @ gmail.com
Ass001FelixBasic PythonNot yet attendedAss015Ass015 @ gmail.com
Ass003TomGeneral informationOverdue02-Dec-20Ass001Ass001 @ gmail.com
Ass002JohnnyBasic PythonDue within 1 month25-Dec-20Ass015Ass015 @ 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
IDassociateAssociateNameCourseNameStatusExipredDateDirectSupIDSupervisorEmail
Ass001FelixGeneral informationOverdue02-Dec-20Ass015Ass015 @ gmail.com
Ass001FelixAdvance AccessNot yet attendedAss015Ass015 @ gmail.com
Ass001FelixBasic PythonNot yet attendedAss015Ass015 @ gmail.com
Ass002JohnnyBasic PythonDue within 1 month25-Dec-20Ass015Ass015 @ 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

..forever waiting... waiting for jellybean!
Local time
Today, 10:06
Joined
May 7, 2009
Messages
19,093
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.
 
Last edited:

uphantom88

New member
Local time
Today, 09:06
Joined
Aug 28, 2020
Messages
4
Hi arnelgp,
Thank you very much for your instruction, I did apply your code, however, an error poped up as below pictures

2020-12-07_15h06_27.png


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

2020-12-07_15h09_36.png
 

uphantom88

New member
Local time
Today, 09:06
Joined
Aug 28, 2020
Messages
4
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

..forever waiting... waiting for jellybean!
Local time
Today, 10:06
Joined
May 7, 2009
Messages
19,093
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

New member
Local time
Today, 03:06
Joined
Aug 15, 2022
Messages
17
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.
 

Users who are viewing this thread

Top Bottom