How To VB: Detect Deleted Appointments in a Recurring Series with Outlook Object Model (260896)

MORE INFORMATION

Private Sub IsApptDeleted()
Dim spApp As Outlook.Application
Dim spMAPI As NameSpace
Dim spFolder As MAPIFolder
Dim spItems As Items
Dim spAppointment As AppointmentItem
Dim spRecurrence As RecurrencePattern
Dim spExceptions As Exceptions
Dim spException As Exception
Dim s As String
Dim k As Integer
Dim i As Long, j As Long

Set spApp = CreateObject("Outlook.Application")
Set spMAPI = spApp.GetNamespace("MAPI")
spMAPI.Logon()
' Get the calendar folder.
Set spFolder = spMAPI.GetDefaultFolder(olFolderCalendar)
Set spItems = spFolder.Items
Debug.Print "Item Count: " & spItems.Count
spItems.Sort("[Start]")
spItems.IncludeRecurrences = True
' Call Find to quickly check for the existence of an appointment.
Set spAppointment = spItems.Find("[Start] = ""01/13/2000 10:00""")
If spAppointment Is Nothing Then
   Debug.Print "Find: Occurrence has been deleted?"
End If
' Iterate through all the appointments checking for deleted occurrences.
If spItems.Count > 0 then
   For i = 1 To spItems.Count
      Set spAppointment = spItems.Item(i)
      If Not (spAppointment Is Nothing) Then
         Debug.Print spAppointment.Subject
         If spAppointment.IsRecurring = True Then
	    Debug.Print " Recurring Appointment"
	    Set spRecurrence = spAppointment.GetRecurrencePattern
            'Get Exceptions collection of RecurrencePattern object.
	    Set spExceptions = spRecurrence.Exceptions
	    If spExceptions.Count > 0 Then
	       For j = 1 To spExceptions.Count
	          Set spException = spExceptions.Item(j)
	          If spException.Deleted = True Then
		     Debug.Print " Deleted"
	          Else
		     Debug.Print " Not Deleted"
                  End If
	          Set spException = Nothing
	       Next j
	    End If 'exceptions count > 0
 	    Set spExceptions = Nothing
	    Set spRecurrence = Nothing
         End If 'If recurring...
         spAppointment.Close(olDiscard)
      Else ' is Null
         Debug.Print "NULL Appointment"
      End If ' is null
      Set spAppointment = Nothing
      'Set a limit to avoid recurring appointments with no end date.
      If i > 50000 Then
         Exit For
      End If
   Next i
End If 'count > 0
Set spItems = Nothing
Set spFolder = Nothing
spMAPI.Logoff
Set spMAPI = Nothing
Set spApp = Nothing

End Sub