(Solved) – Looping two recordsets in VBA for Access


I am trying to send email records from a query called “Deprog3” to multiple different recipients. The button on the form needs to loop through each record in the form and send an email to the recipient (‘Me.EMAIL’). The email it sends should select all of the records from the “Deprog3” query that relate to that particular individual.

What actually happens though is that it sends just the records specific to the first individual on the first email, then it sends the records from the first AND second individuals on the second email and so on until the last email contains every record from the query.

If I comment out the second line (‘Do While Me.Current Record…’) and the second from last line (‘Loop’), it takes out the looping and means I have to keep clicking ‘Send’, but it doesn’t send the records from the previous individuals.

Any guidance would be greatly appreciated!

Private Sub Send_Click()

Do While Me.CurrentRecord < Me.Recordset.RecordCount

DoCmd.RunSQL "delete * from sendfiletemp"
DoCmd.OpenQuery "Deprog3"

Dim MyDB As DAO.Database
Dim rst As DAO.Recordset

Set MyDB = CurrentDb
Set rst = MyDB.OpenRecordset("SendFileTemp", dbOpenForwardOnly)

strSMTPFrom = Me.From
strBCC = Me.BCC
strSMTPRelay = "mail.vaioni.com"
strSubject = "Jobs requiring your attention"

With rst
  Do While Not .EOF
    MailBody = MailBody & ![serviceid] & " | " & ![status] & " | " & ![EventDate] & " | " & ![name] & vbCrLf
End With

Set oMessage = CreateObject("CDO.Message")
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPRelay
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

oMessage.From = strSMTPFrom
oMessage.To = strSMTPTo
oMessage.bcc = strBCC
oMessage.Subject = strSubject
oMessage.TextBody = "Can you please take a look at these jobs that remain open and close them down. Thanks  " & vbCrLf & " " & vbCrLf & MailBody & vbCrLf & " "


Set rst = Nothing



End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *