Send E-mail to multiple recipients containing thier records via CDO

I have a code that currently sends an HTML formatted message which query from a DB for records then send out to specific group of people.

But i want to expand the code feature into looking up recipients from a table in DB and send out information HTML formatted containing records for the particular recipient.
Code

Public Function sendmail()

    Dim db As DAO.Database
    Dim rec As DAO.Recordset
    Dim strQry, strTo As String
    Dim aHead(1 To 11) As String
    Dim aRow(1 To 11) As String
    Dim aBody(), aBody2 As String
    Dim lCnt As Long
    Dim getdate As String
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant


    aHead(1) = "RecordID"
    aHead(2) = "Name"
    aHead(3) = "Gender"
    aHead(4) = "Transaction Code"
    aHead(5) = "Mobile"

    lCnt = 1
    ReDim aBody(1 To lCnt)
    aBody(lCnt) = "<HTML><body><br>Dear All,</br> <br>Good Day.</br> <br>Please refer below for the details of your current system records & " & _
    "Kindly assist to check and confirm. </br>  " & _
    "<br><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"

    strQry = "SELECT * FROM tblrecon "
    Set db = CurrentDb
    Set rec = CurrentDb.OpenRecordset(strQry)
    If rec.RecordCount <> 0 Then

    If Not (rec.EOF) Then
        Do While Not rec.EOF
            strTo = rec.Fields("Email")
            lCnt = lCnt + 1
            ReDim Preserve aBody(1 To lCnt)
            aRow(1) = rec("RecordID")
            aRow(2) = rec("Name")
            aRow(3) = rec("Gender")
            aRow(4) = rec("TransactionCode")
            aRow(5) = rec("Mobile")
            aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
            rec.MoveNext
        Loop
    End If

        aBody(lCnt) = aBody(lCnt) & "</table></body></html> <br> Sincerly, </br> <br> System Operator </br>"

        Set iMsg = CreateObject("CDO.Message")
        Set iConf = CreateObject("CDO.Configuration")
        iConf.Load -1
        Set Flds = iConf.Fields
        With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "MySMTPServer"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = "Myport"
        .Update
        End With

            With iMsg
            Set .Configuration = iConf
            Do While rec.EOF And (rec.Fields("Email") = strTo)
            .HTMLBody = Join(aBody, vbNewLine)
            rec.MoveNext
            Loop

            .To = strTo
            .BCC = ""
            .From = "Test@TestMail.com"
            .Subject = "Record Summary"
            .send
            End With
        Set iMsg = Nothing
        Set iConf = Nothing
        Set Flds = Nothing

        Else
    Exit Function
End If
End Function

Solution

If you want individual email to each addressee and include only records that pertain to each email, then build email body of records within loop of email addresses. This means opening a recordset of email addresses and then within that loop open a recordset of related data records and loop through that recordset.

Public Function sendmail()

    Dim db As DAO.Database
    Dim rec As DAO.Recordset
    Dim mail As DAO.Recordset

    Dim aHead(1 To 11) As String
    Dim aRow(1 To 11) As String
    Dim aBody(), aBody2 As String
    Dim lCnt As Long
    Dim getdate As String
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant

    aHead(1) = "RecordID"
    aHead(2) = "Name"
    aHead(3) = "Gender"
    aHead(4) = "Transaction Code"
    aHead(5) = "Mobile"

    Set db = CurrentDb
    Set mail = db.OpenRecordset("SELECT DISTINCT Email FROM tblrecon")

    While Not mail.EOF
        lCnt = 1
        ReDim aBody(1 To lCnt)
        aBody(lCnt) = "<HTML><body><br>Dear All,</br> <br>Good Day.</br> <br>Please refer below for the details of your current system records & " & _
        "Kindly assist to check and confirm. </br>  " & _
        "<br><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
        Set rec = db.OpenRecordset("SELECT * FROM tblrecon WHERE Email='" & mail!Email & "'")
        If Not rec.EOF Then
            Do While Not rec.EOF
                lCnt = lCnt + 1
                ReDim Preserve aBody(1 To lCnt)
                aRow(1) = rec("RecordID")
                aRow(2) = rec("Name")
                aRow(3) = rec("Gender")
                aRow(4) = rec("TransactionCode")
                aRow(5) = rec("Mobile")
                aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
                rec.MoveNext
            Loop
            rec.Close
        End If

        aBody(lCnt) = aBody(lCnt) & "</table></body></html> <br> Sincerly, </br> <br> System Operator </br>"

        Set iMsg = CreateObject("CDO.Message")
        Set iConf = CreateObject("CDO.Configuration")
        iConf.Load -1
        Set Flds = iConf.Fields
        With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "MySMTPServer"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = "Myport"
        .Update
        End With

        With iMsg
        Set .Configuration = iConf
        .HTMLBody = Join(aBody, vbNewLine)
        .To = mail!Email
        .BCC = ""
        .From = "Test@TestMail.com"
        .Subject = "Record Summary"
        .Send
        End With
        mail.MoveNext
    Loop
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End

This can be done with 1 ordered recordset but that would require setting a variable with email address from record and checking when that email changes in recordset to determine when email should be sent and start a new set of records for next email.