Update an Outlook Appointment

[Legacy 128378]

I am trying to find and then change the categories from Acitve to Cancelled to chaned the appointment color from green to red. The code I am using to create the appointment works great but I cannot get the code to change the appointment to work. Below is the code that contiues to error.

Thanks!

Private Sub UpdateAppt_Click()
Dim olook As New Outlook.Application
Dim olookns As Outlook.NameSpace
Dim CalItem As Outlook.MAPIFolder
Dim ApptItem As Outlook.AppointmentItem
Set olookns = olook.GetNamespace("MAPI")
Set CalItem = olookns.GetDefaultFolder(olFolderCalendar)
CalItem.Items.Sort ("[Start]")

Set ApptItem = CalItem.Items.Find("[Subject] = """ & Me!ID & """")
If Appointment.Categories = Active Then
With ApptItem
.Categories = Cancelled
If objAppt Is Nothing Then
MsgBox "appointment not found"
End If
.Save
Set Appointment = Nothing
Set oOutlook = Nothing
End With
Set objOutlook = Nothing
Exit Sub
End Sub