VB Updating Appointments from Access Query

Tech-Archive recommends: Fix windows errors by optimizing your registry

I am trying to create Outlook Appointments for our field staff from an
access query that is being pulled from our SQL DB. I am using Visual
Basic. I am getting the information to go to the correct place but
instead of creating a new appointment based on seperate values in the
query it keeps updating the same appointment. This is wildly
frustrating because it is pulling the correct data. But when I send
all the messages there is only one appointment when there should be a
bunch.

Here is the Code:

Private Sub Appointments()

'Add a new appointment.
Dim dbCustomers As Object
Dim rstCustomers As Object
Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim IntI As Integer

Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)
Set dbCustomers = CurrentDb
Set rstCustomers = dbCustomers.OpenRecordset("Drive
Appointments")
Set objNS = objOutlook.GetNamespace("MAPI")
objNS.Logon


If rstCustomers.RecordCount = 0 Then
MsgBox "No Records To Process"
Exit Sub
End If


objAppt.MeetingStatus = 1


rstCustomers.MoveLast
rstCustomers.MoveFirst
For IntI = 0 To rstCustomers.RecordCount - 1
Do Until rstCustomers.EOF

With objAppt

.RequiredAttendees = rstCustomers.email
.Start = rstCustomers.Expr1
.Duration = rstCustomers.sched_dur
.Subject = rstCustomers.work_no
.ResponseRequested = True


If Not IsNull(rstCustomers.Description) Then .Body =
rstCustomers.location_name & " / " & rstCustomers.addr1 & " / " &
rstCustomers.city & " / " & rstCustomers.state_code
If Not IsNull(rstCustomers.location_name) Then .Location =
rstCustomers.location_name
AddedToOutlook = True
.Save
.Send
rstCustomers.Edit
rstCustomers.Update
IntI = IntI + 1
Set objAppt = Nothing
Set objAppt = objOutlook.CreateItem(olAppointmentItem)
End With

rstCustomers.MoveNext
Exit For
Loop
rstCustomers.Close
Next
Set objAppt = Nothing
MsgBox "Your appointments have been added to your Outlook
Calendar"


'Release the AppointmentItem object variable.
Set objAppt = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
Set SafeItem = Nothing
Set rstCustomers = Nothing


Exit Sub


End Sub

I hope this is an easy fix because I am close to losing my mind.

.

Relevant Pages