My qryDataToSend has following result:
KeyField Full_Name COURSE NPDD CENSUS LDTD Email
jd1001 John Doe ART 001-0101 1/15/2015 2/16/2015 3/17/2015 johndoe@fakeema il.com
jd1001 John Doe ART 023-0202 1/16/2015 2/17/2015 3/18/2015 johndoe@fakeema il.com
my1002 May Yee MATh 115-0303 7/1/2015 8/2/2015 9/3/2015 mayyee@thisemai l.com
my1002 May Yee LAW 001-0505 8/1/2015 9/4/2015 10/20/2015 mayyee@thisemai l.com
my1002 May Yee LAW 002-0303 9/1/2015 9/9/1015 10/30/2015 mayyee@thisemai l.com
So I want to send an email to each instructor with his/her course in the outlook body. Following code result 1 email to the first faculty only with all 5 courses. I understand I need another loop (while keyField) to get it work but I cannot figure this out.Please help me with this outer loop. Thanks.
KeyField Full_Name COURSE NPDD CENSUS LDTD Email
jd1001 John Doe ART 001-0101 1/15/2015 2/16/2015 3/17/2015 johndoe@fakeema il.com
jd1001 John Doe ART 023-0202 1/16/2015 2/17/2015 3/18/2015 johndoe@fakeema il.com
my1002 May Yee MATh 115-0303 7/1/2015 8/2/2015 9/3/2015 mayyee@thisemai l.com
my1002 May Yee LAW 001-0505 8/1/2015 9/4/2015 10/20/2015 mayyee@thisemai l.com
my1002 May Yee LAW 002-0303 9/1/2015 9/9/1015 10/30/2015 mayyee@thisemai l.com
So I want to send an email to each instructor with his/her course in the outlook body. Following code result 1 email to the first faculty only with all 5 courses. I understand I need another loop (while keyField) to get it work but I cannot figure this out.Please help me with this outer loop. Thanks.
Code:
Option Compare Database
Option Explicit
Public Function send_mail()
'Create application and mail objects
Dim olApp As Object
Dim objMail As Object
Dim rs As DAO.Recordset
Dim strID As String
Dim strHeader As String
Dim strText As String
Dim strName As String
Dim strEmail As String
strText = ""
Dim qd As QueryDef
Set qd = CurrentDb.QueryDefs!qryDataToSend
'Create a record set and run the query defined above
Set rs = qd.OpenRecordset()
If (rs.BOF = True And rs.EOF = True) Then
'No record to process, should exit
Else
rs.MoveFirst
End If
Set olApp = CreateObject("Outlook.Application") 'Create a new instance
'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)
'Email header
strName = rs!Full_Name
strEmail = rs!email
With objMail
.BodyFormat = olFormatHTML
.To = strEmail
.Subject = "Deadline Reminder"
.HTMLBody = "<!DOCTYPE html>"
.HTMLBody = .HTMLBody & "<html><head><style>table, th, td {border: 1px solid black}</style><body>"
.HTMLBody = .HTMLBody & "Dear " & strName & "," & "<p>"
.HTMLBody = .HTMLBody & "Below are your courses that the NPDD deadline is near."
.HTMLBody = .HTMLBody & "<table style='width:40%'>"
.HTMLBody = .HTMLBody & "<tr bgcolor='#AAAAAA'><td>COURSE</td>"
.HTMLBody = .HTMLBody & "<td align='center'>NPDD</td>"
.HTMLBody = .HTMLBody & "<td align='center'>CENSUS</td>"
.HTMLBody = .HTMLBody & "<td align='center'>LDTD</td></tr>"
End With
strID = rs!keyfield
While Not rs.EOF
'Add each entry to the body
With objMail
.HTMLBody = .HTMLBody & "<tr><td>" & rs!COURSE & "</td>"
.HTMLBody = .HTMLBody & "<td align='center'>" & rs!NPDD & "</td>"
.HTMLBody = .HTMLBody & "<td align='center'>" & rs!CENSUS & "</td>"
.HTMLBody = .HTMLBody & "<td align='center'>" & rs!LDTD & "</td></tr>"
End With
rs.MoveNext
Wend
'Add end of the body and send
With objMail
.HTMLBody = objMail.HTMLBody & "</Table></Body>" & vbNewLine & "Signature" & vbCrLf & "Company"
'.send
.Display
End With
Set olApp = Nothing
Set objMail = Nothing
End Function
Comment