Trying to modify Existing Outlook Appt Item Using Access

Using the form shown and code attached, I am able to successfully add an appointment in to an Outlook Calendar from Access.  At the same time, I also capture the EntryID of the appointment and store it in the Access table.  I did this thinking it would be the easiest and most unique way to find the entry at a later time.

(The four fields on the bottom right corner are normally hidden.  First one is the AppointmentID in Access table, second is oldApptDate in case date is being changed, third is ApptLength, and fourth is the captured Outlook EntryID.)

I am now also trying to account for the situation where the end user pulls up an existing appointment in Access (and also already in Outlook), and wants to modify it in some way (i.e. change to a different day, different time, add a note, etc.).  The code I am trying to use in the "modify" situation is in the section marked "Check to see if Appt is already in Outlook and, if so, modify instead of adding new."

When I pull up an existing appt, the code runs and completes giving me the "Appointment Modified!" message.  No errors!  However, the end result is that the Access table entry was modified, but the Outlook entry remains unchanged.

I also tried this with the If statement to compare EntryID instead of Subject:
If InStr(outappt.EntryID, Forms![frmAppointments]![EntryID]) Then

as well with the same result.  Can someone help me identify why my code is not modifying the Outlook record for the appointment?

Thanks!

Private Sub cmdNewRecord_Click()

Dim apptdat As Date
Dim apptStrTim As Date
Dim apptEndTim As Date

Dim outobj As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim outappt As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)

Dim colCal As Outlook.Items
Dim colMyAppts As Outlook.Items
Dim intApptsKilled As Integer
Dim strFind As String
Set objapp = CreateObject("Outlook.Application")
Set objNS = objapp.GetNamespace("MAPI")
Set colCal = objNS.GetDefaultFolder(olFolderCalendar).Items
colCal.Sort "[Start]"
colCal.IncludeRecurrences = False

    Forms!frmAppointments.FilterOn = False
    
' Save record first to be sure required fields are filled.

    Me.ApptLength = DateDiff("n", ApptStartTime, ApptEndTime)

    DoCmd.RunCommand acCmdSaveRecord
    
    apptdat = Format(Forms![frmAppointments]![ApptDate], "dd mmm yyyy")
    apptStrTim = Format(Forms![frmAppointments]![ApptStartTime], "hh:mm AM/PM")
    apptEndTim = Format(Forms![frmAppointments]![ApptEndTime], "hh:mm AM/PM")
    
' Check to see if Appt is already in Outlook and, if so, modify instead of adding new.

If Me!AddedToOutlook = True Then

    apptdat = Forms![frmAppointments]![oldApptDate]

    'get appointments spanning 24hrs in date range of current day
    strFind = "[Start] > " & _
            Quote(apptdat & " 12:00 AM") & " AND [End] < " & _
            Quote(apptdat & " 11:59 PM")

    intApptsKilled = 0
    Set colMyAppts = colCal.Restrict(strFind)
    For Each outappt In colMyAppts
        If InStr(outappt.Subject, Forms![frmAppointments]![Appt]) Then

            Dim db As Database
            Dim appts_RST As Recordset
            Set db = CurrentDb
            Set appts_RST = db.OpenRecordset("tblAppointments", dbOpenDynaset)
            
            appts_RST.MoveFirst
            Do While (Not appts_RST.EOF)
            
                If (appts_RST![AppointmentID] = Forms![frmAppointments]![AppointmentID]) Then
                
                    Exit Do
                End If
                appts_RST.MoveNext
            Loop

            With outappt
                .Start = Me.ApptDate
                .Duration = Me.ApptLength
                .Subject = Me.Appt
                If Not IsNull(Me.ApptNotes) Then .Body = Me.ApptNotes
                If Not IsNull(Me.ApptLocation) Then .Location = Me.ApptLocation
                .ReminderSet = Me.ApptReminder
                If (Me.ApptReminder = True) Then .ReminderMinutesBeforeStart = Me.ReminderMinutes
                .Save
            End With
            
            intApptsKilled = intApptsKilled + 1
        End If
    Next
    
    ' Release the Outlook object variable.
        Set objapp = Nothing
    
    ' Set the AddedToOutlook flag, save the record, move to new record, and display a message.
        DoCmd.GoToRecord , , acNewRec
        MsgBox "Appointment Modified!"
        Exit Sub

Else
' Add a new appointment.
    With outappt
        .Start = Me!ApptDate & " " & Me!ApptStartTime
        .Duration = Me!ApptLength
        .Subject = Me!Appt
        If Not IsNull(Me!ApptNotes) Then .Body = Me!ApptNotes
        If Not IsNull(Me!ApptLocation) Then .Location = Me!ApptLocation
        If Me!ApptReminder Then
            .ReminderMinutesBeforeStart = Me!ReminderMinutes
            .ReminderSet = True
        End If
        .Save
        
'get appointments spanning 24hrs in date range of current day
  strFind = "[Start] > " & _
            Quote(apptdat & " 12:00 AM") & " AND [End] < " & _
            Quote(apptdat & " 11:59 PM")
            

'Looks up appointment just logged to retrieve its unique EntryID to store in Access table entry
  intApptsKilled = 0
  Set colMyAppts = colCal.Restrict(strFind)
  For Each outappt In colMyAppts
    If InStr(outappt.Subject, Forms![frmAppointments]![Appt]) Then

        'MsgBox (outappt.EntryID)
        Me!EntryID = (outappt.EntryID)
        intApptsKilled = intApptsKilled + 1
     End If
  Next
        
    End With
End If

' Release the Outlook object variable.
    Set objapp = Nothing
    
' Set the AddedToOutlook flag, save the record, move to new record, and display a message.
    Me!AddedToOutlook = True
    DoCmd.GoToRecord , , acNewRec
    MsgBox "Appointment Added!"
    Exit Sub

AddAppt_Err:

    MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub

End Sub

Select allOpen in new window