Solved VBA code for deleting Outlook 'Appointments' lying within a specified date range

[alan2013]

On an Access form, I have an unbound 'unbCalendarUpdates_FromDate' field, an unbound 'unbCalendarUpdates_ToDate' field, and a 'btnCalendarUpdates' button. On the 'On Click' Event for the button, I have the following VBA code. What I'm trying to do is to delete all Appointments (lying within a specified date range) from my Microsoft Outlook Calendar. (Later, I'll be introducing VBA code for repopulating my Calendar with updated info held within my Access database).

At present, my Appointments are not being deleted. Can anyone help me understand why that's the case ? Thanks in advance for any guidance.

Private Sub btnCalendarUpdates_Click()
Dim olApp As Object 'Late binding - No Outlook reference needed.
Dim olNS As Object
Dim olFolder As Object
Dim olItems As Object
Dim filteredItems As Object
Dim olAppt As Object
Dim filter As String
Dim i As Long
  
'Start Outlook if not already running
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
    Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0

If olApp Is Nothing Then
    MsgBox "Unable to start Outlook.", vbExclamation
    Exit Sub
End If

Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9) ' 9 = olFolderCalendar
Set olItems = olFolder.Items

'Sort and include recurring appointments
olItems.Sort "[Start]"
olItems.IncludeRecurrences = True

Dim DateRange_From As Date
Dim DateRange_To As Date
DateRange_From = Me.unbCalendarUpdates_FromDate
DateRange_To = Me.unbCalendarUpdates_ToDate

'Construct the filter string
filter = "[Start] >= '" & Format(DateRange_From, "mm/dd/yyyy hh:nn AM/PM") & _
         "' AND [Start] <= '" & Format(DateRange_To, "mm/dd/yyyy hh:nn AM/PM") & "'"

'Apply filter
Set filteredItems = olItems.Restrict(filter)
'Set oFilteredAppointments = oAppointmentItems.Restrict(sFilter)

'MsgBox "Count of filtered items : " & filteredItems.Count

'Loop backwards, to delete safely
For i = filteredItems.Count To 1 Step -1
    Set olAppt = filteredItems.Item(i)
    olAppt.Delete
Next i
    
End Sub

 

[theDBguy]

Have you tried stepping through the code and examine the properties of each event you were able to capture?

 

[arnelgp]

chatGPT suggest to use this format for your filter:

filter = "[Start] >= '" & Format(dateRange_from, "ddddd h:nn AMPM") & "' AND [Start] <= '" & Format(dateRange_To, "ddddd h:nn AMPM") & "'"

 

[alan2013]

I'm trying that out (ie the filter in that format). Early indications were that it'd worked. But on further investigation, I see that there are many Outlook Calendar 'Appointments' that have not been deleted, despite being within the date-range specified by me. I'm trying to establish whether there is any pattern to the left-over Appointments that might help me to know how to tweak the VBA code...

 

[Gasman]

Well, the advice in post #2 is always where I start from?

I get this with your code and I have hardly any appointments in my selected range. I even added one to be sure at least one was found.

? filter
[Start] >= '02/01/2025 12:00 AM' AND [Start] <= '04/30/2025 12:00 AM'

? filteredItems.Count
2147483647

 

[Gasman]

ChatGPT shows this for recurring appointments

Sub DeleteAppointmentsIncludingRecurring()
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olCalendar As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olItem As Object
    Dim olAppt As Outlook.AppointmentItem
    Dim StartDate As Date
    Dim EndDate As Date
    Dim Filter As String
    Dim i As Long

    ' Set your desired date range
    StartDate = #5/10/2025#    ' Change as needed
    EndDate = #5/15/2025#      ' Change as needed

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olCalendar = olNS.GetDefaultFolder(olFolderCalendar)
    Set olItems = olCalendar.Items

    olItems.IncludeRecurrences = True
    olItems.Sort "[Start]"

    Filter = "[Start] >= '" & Format(StartDate, "ddddd h:nn AMPM") & "' AND [Start] <= '" & Format(EndDate, "ddddd h:nn AMPM") & "'"
    Set olItems = olItems.Restrict(Filter)

    ' Loop through items backwards for safe deletion
    For i = olItems.Count To 1 Step -1
        Set olItem = olItems.Item(i)
        If TypeName(olItem) = "AppointmentItem" Then
            Set olAppt = olItem
            ' Optional: confirm deletion of recurring master
            If olAppt.IsRecurring Then
                Dim olPattern As Outlook.RecurrencePattern
                Set olPattern = olAppt.GetRecurrencePattern
                If olPattern.PatternStartDate <= EndDate And olPattern.PatternEndDate >= StartDate Then
                    olAppt.Delete ' Deletes the entire series
                End If
            Else
                olAppt.Delete
            End If
        End If
    Next i

    MsgBox "Appointments within the specified range have been deleted.", vbInformation
End Sub

You do not appear to be checking if the item is an appointment?

 

[MarkK]

A faster way to get at your Outlook data is to use an Outlook.Table object, so you might have a function...

Function GetItemTable(Folder As Outlook.Folder, Optional FromDate As Date) As Outlook.Table
    If FromDate = 0 Then
        Set GetItemTable = Folder.GetTable
    Else
        Set GetItemTable = Folder.GetTable(GetFilter("ByDate", FromDate))
    End If
End Function

... and then you could do...

Private Sub DeleteTableItems(olt As Outlook.Table)
    Dim olr As Outlook.row
    
    Do While Not olt.EndOfTable
        Set olr = olt.GetNextRow()
        DeleteItemByEntryID olr.item("EntryID")
    Next
End Sub

Sub DeleteItemByEntryID(EntryID As String)
    Dim item As Object
    
    Set item = ns.GetItemFromID(EntryID)
    If Not item Is Nothing Then item.Delete
End Sub

This code is not complete, but in the database at work I present data from a shared calendar with around 850 items, and loading them all into classes using an Outlook.Table takes less than 0.8 sec. By contrast, loading all the data from the actual Outlook.AppointmentItem objects takes around 6-8 sec. So if your volume is high and your process is slow, you can look at using an Outlook.Table for data access.

 

[alan2013]

Well, the advice in post #2 is always where I start from?

I get this with your code and I have hardly any appointments in my selected range. I even added one to be sure at least one was found.

? filter
[Start] >= '02/01/2025 12:00 AM' AND [Start] <= '04/30/2025 12:00 AM'

? filteredItems.Count
2147483647

Yes, I initially got a Count like that. I found that when I commented out the line about recurrences (olItems.IncludeRecurrences = True), I got a true count of my Appointments within my specified date-range. In my case (as I won't be using the 'recurring' Appointment functionality within Outlook), it's okay to remove that line.

 

[Gasman]

Ok, I commented out the recurrence line and then got 7 appts.
I used display to open them and they matched my criteria, and ones that were recurring that started back in 2024, but fell within my date range.
So you might need to do more work, if you want to keep future recurrences. You will need to do some more research and ask ChatGPT more questions.