How to create and send emails from Access database - ms-access

Question

I have a query that generates a table like this:
Row 1 - ID 1 Peter Parker Task 1 $50
Row 2 - ID 1 Peter Parker Task 2 $55
Row 3 - ID 1 Peter Parker Task 3 $60
Row 4 - ID 2 Mary Jane Task 1 $45
Row 5...
I want to be able to send one email to each person with a list of the tasks and amounts, and the total amount:
Peter Parker
Task 1 $50
Task 2 $55
Task 3 $60
Total $165
I've got a module that sends email, but it requires a single recipient per row. I'm thinking I need another loop, but I'm lost as how to do this.
Here's the code I'm using now:
Sub SendMessages(Optional AttachmentPath)
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachments
Dim TheAddress As String
Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("qry_TeacherPayment - Round 2")
MyRS.MoveFirst
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
Do Until MyRS.EOF
'Set loop variables
Dim currentRecord As Integer
Dim oldRecord As Integer
Dim totalAmt As Double
currentRecord = MyRS![ID]
totalAmt = 0
If (currentRecord = MyRS![ID]) Then
' Create the e-mail message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
oldRecord = currentRecord
TheAddress = MyRS![WorkEmail]
With objOutlookMsg
' Add the To recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add("TheAddress")
objOutlookRecip.Type = olTo
' Set the from address.
objOutlookMsg.SentOnBehalfOfName = "email"
' Set the Subject, the Body, and the Importance of the e-mail message.
.Subject = "Subject"
objOutlookMsg.BodyFormat = olFormatHTML
body text
.HTMLBody = .HTMLBody & "</table></body></html>"
.Importance = olImportanceNormal 'Normal importance
' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Send
End With
End If
MyRS.MoveNext
Loop
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
DoCmd.SetWarnings True
End Sub

Answer 1

Here is my final code that works a treat. A huge thanks to maxhugen for putting me on the right path!!
Cheers!
Jason
Sub SendNewPaymentEmail(Optional AttachmentPath)
Dim MyDB As Database
Dim MyRS As Recordset
Dim LastTeacherID As Integer
Dim EmailBody As String
Dim TotalAmount As Double
Dim TheAddress As String
Dim TeacherFirstName As String
Dim FinalTeacherID As Integer
Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("qry_TeacherPayment - Round 2")
MyRS.MoveFirst
LastTeacherID = MyRS![ID]
Do Until MyRS.EOF
If MyRS![ID] = LastTeacherID Then
TheAddress = MyRS![WorkEmail]
TeacherFirstName = MyRS![FirstName]
FinalTeacherID = MyRS![TeacherID]
EmailBody = EmailBody & "<tr><td>" & MyRS![Subject] & " Year " & MyRS![Year] & "</td><td>" & MyRS![TaskName] & "</td><td>$" & MyRS![Teacher Payment] & "</td></tr>"
TotalAmount = TotalAmount + Nz(MyRS![Teacher Payment], 0)
DoCmd.SetWarnings False
DoCmd.RunSQL "Update [tbl_Judging Standards Project round 2] SET [PaymentEmailSent] = -1 WHERE [TeacherID] = " & MyRS![ID] & " AND [TaskIDTRIM] LIKE '" & MyRS![TaskIDTRIM] & "'"
DoCmd.RunSQL "Update [tbl_Judging Standards Project round 2] SET [PaymentEmailSentDate] = Now() WHERE [TeacherID] = " & MyRS![ID] & " AND [TaskIDTRIM] LIKE '" & MyRS![TaskIDTRIM] & "'"
DoCmd.SetWarnings True
Else
Call CreateEmail(EmailBody, TotalAmount, TeacherFirstName)
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO [tbl_Payments]([TeacherID],[PaymentType],[Amount],[Description],[PaymentFormSent],[PaymentFormSentDate]) VALUES(" & FinalTeacherID & ", 'Individual Payment'," & TotalAmount & ",'Judging Standards Project Phases 2 and 3 - Payment for work samples - Round 2', -1, NOW())"
DoCmd.SetWarnings True
'reset variables
EmailBody = ""
TotalAmount = 0
'start again
TheAddress = MyRS![WorkEmail]
TeacherFirstName = MyRS![FirstName]
LastTeacherID = MyRS![ID]
FinalTeacherID = MyRS![TeacherID]
EmailBody = EmailBody & "<tr><td>" & MyRS![Subject] & " Year " & MyRS![Year] & "</td><td>" & MyRS![TaskName] & "</td><td>$" & MyRS![Teacher Payment] & "</td></tr>"
TotalAmount = TotalAmount + Nz(MyRS![Teacher Payment], 0)
DoCmd.SetWarnings False
DoCmd.RunSQL "Update [tbl_Judging Standards Project round 2] SET [PaymentEmailSent] = -1 WHERE [TeacherID] = " & MyRS![ID] & " AND [TaskIDTRIM] LIKE '" & MyRS![TaskIDTRIM] & "'"
DoCmd.RunSQL "Update [tbl_Judging Standards Project round 2] SET [PaymentEmailSentDate] = Now() WHERE [TeacherID] = " & MyRS![ID] & " AND [TaskIDTRIM] LIKE '" & MyRS![TaskIDTRIM] & "'"
DoCmd.SetWarnings True
End If
MyRS.MoveNext
If (MyRS.EOF) Then
Call CreateEmail(EmailBody, TotalAmount, TeacherFirstName)
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO [tbl_Payments]([TeacherID],[PaymentType],[Amount],[Description],[PaymentFormSent],[PaymentFormSentDate]) VALUES(" & FinalTeacherID & ", 'Individual Payment'," & TotalAmount & ",'Judging Standards Project Phases 2 and 3 - Payment for work samples - Round 2', -1, NOW())"
DoCmd.SetWarnings True
End If
Loop
End Sub

Answer 2

Assuming MyRS is returning fields something like PersonID, TaskID, TaskAmt, you need to loop through MyRS and add the Task and Amt to a string variable (eg 'strBody') UNTIL the PersonID changes - at which point you prepare and send the email using objOutlookMsg.
Set MyRS = ...
LastPersonID=MyRS!PersonID
Do Until MyRS.EOF
If MyRS!PersonID=LastPersonID Then
' concatenate to strBody
strBody = strBody & TaskID & " " & TaskAmt
' add Amt to Person's Total
decTotal = decTotal + nz(TaskAmt,0)
Else
' add the Total
strBody = strBody & "Total: " & decTotal
' send email using another function, or GoTo a named line,
' using LastPersonID and strBody
GoTo send_email
' reset the variables
strBody = ""
decTotal = 0
' concatenate to strBody
strBody = strBody & TaskID & " " & TaskAmt & "<br/>"
' add Amt to Person's Total
decTotal = decTotal + nz(TaskAmt,0)
End If
MyRS.MoveNext
Loop