I have this code (below) that loops through a recordset and sends appointments. It executes the queries correctly and sends all appointments in the table, but sends them only to the contacts listed in the first record of the query. How do I get it to loop the contact details?
Can you point out anything wrong with the code?
Can you point out anything wrong with the code?
Code:
Private Sub SchedFollowUp()
Dim rsFollow As DAO.Recordset
Set rsFollow = CurrentDb.OpenRecordset("SELECT * FROM Follow_Up WHERE HR_Approved = True AND Added_to_Outlook = False AND Cancelled = False;", dbOpenDynaset)
Dim rsEmployee As DAO.Recordset
Set rsEmployee = CurrentDb.OpenRecordset("SELECT * FROM Employee INNER JOIN Follow_Up ON Employee.EMP_ID = Follow_Up.Emp_ID;", dbOpenDynaset)
Dim rsMentor As DAO.Recordset
Set rsMentor = CurrentDb.OpenRecordset("SELECT * FROM Employee INNER JOIN Follow_Up ON Employee.EMP_ID = Follow_Up.Mentor_ID;", dbOpenDynaset)
With rsFollow
rsFollow.MoveFirst
Do Until rsFollow.EOF
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)
With outappt
.MeetingStatus = olMeeting
.Start = rsFollow!FU_DT & " " & rsFollow!FU_Start_Time
.Duration = rsFollow!FU_Duration
.RequiredAttendees = rsEmployee!EMAIL_ADDRESS & "; " & rsMentor!EMAIL_ADDRESS
.OptionalAttendees = rsEmployee!TM_EMAIL_ADDRESS & "; " & rsMentor!TM_EMAIL_ADDRESS
.Subject = "Follow-up Session ID# " & rsFollow!FU_Session_ID
.Body = "test"
.Location = "test"
.ReminderMinutesBeforeStart = 15
.ReminderSet = True
.Save
.Send
End With
If rsFollow!Added_to_Outlook = False Then
rsFollow.Edit
rsFollow!Added_to_Outlook = True
rsFollow.Update
End If
rsFollow.MoveNext
Loop
End With
rsFollow.Close
Set rsFollow = Nothing
rsAgent.Close
Set rsAgent = Nothing
rsNHD.Close
Set rsNHD = Nothing
End Sub