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.