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