我有一个生成如下表格的查询：
第1行 - 身份证1彼得帕克任务1 $ 50
第2行 - 身份证1 Peter Parker任务2 $ 55
第3行 - ID 1 Peter Parker任务3 $ 60
第4行 - ID 2 Mary Jane任务1 $ 45
第5行......
我希望能够向每个人发送一封电子邮件，其中包含任务和金额列表以及总金额：
彼得帕克任务1 $ 50
任务2 $ 55
任务3 $ 60
总计165美元
我有一个发送电子邮件的模块，但每行需要一个收件人。我认为我需要另一个循环，但我已经失去了如何做到这一点。
这是我现在使用的代码：
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
答案 0 :(得分：1)
这是我的最终代码。非常感谢maxhugen让我走上了正确的道路!!
干杯！
杰森
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
答案 1 :(得分：0)
假设MyRS返回类似PersonID，TaskID，TaskAmt的字段，您需要循环访问MyRS并将Task和Amt添加到字符串变量（例如＆＃39; strBody＆＃39;）UNTIL PersonID更改 - 在指出你准备并使用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