VBA code to delete specific calendar events

I have the following lines of code that I am trying to use to remove specific calendar events prior to adding the updated events back using an sql server recordset.  When I run the code, it will delete some of the events, but I have to run it several times to delete all of the events. How can I change this code to delete ALL events in one code run that meet the subject criteria?

Dim myStart, myEnd As Date
    Dim oCalendar As Outlook.Folder
    Dim oItems As Outlook.Items
    Dim oResItems As Outlook.Items
    Dim oAppt As Outlook.AppointmentItem
    Dim strRestriction As String
  myStart = Date - 1
    myEnd = Date + 10
   

    Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
    Set oItems = oCalendar.Items
      strRestriction = "[Start] <= '" & myEnd & "' AND [End] >= '" & myStart & "'"
      Set oResItems = oItems.Restrict(strRestriction)
    For Each oAppt In oResItems
     ' delete PTO entries
       If InStr(1, oAppt.Subject, "PTO:", vbTextCompare) > 0 Then
            oAppt.Delete
        End If

    Next
LVL 1
BradleyClevelandAsked:
Who is Participating?
 
David LeeConnect With a Mentor Commented:
Hi, BradleyCleveland.

There are two reasons the code would miss some appointments.  First, when deleting items you can't use a "FOR EACH" loop.  When you delete an item it changes the position of the items that appear after it.  This results in items being skipped.  Instead, you need to work backwards, starting at the end of the list and working toward its beginning.  To do this you use a "FOR x = COUNT OF ITEMS IN THE LIST TO 1 STEP -1".  Second, when dealing with appointments you have to consider recurring items.  To get the recurring items you need to sort the list by the start date and set IncludeRecurrences to True.  I've modified the code to do both.  Please give it a try and let me know if that does it for you.

Sub DeleteAppointments()
    Dim myStart, myEnd As Date
    Dim oCalendar As Outlook.Folder
    Dim oItems As Outlook.Items
    Dim oResItems As Outlook.Items
    Dim oAppt As Outlook.AppointmentItem
    Dim strRestriction As String
    Dim intCnt As Integer
    myStart = Date - 1
    myEnd = Date + 10
    Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
    Set oItems = oCalendar.Items
    strRestriction = "[Start] <= '" & myEnd & "' AND [End] >= '" & myStart & "'"
    Set oResItems = oItems.Restrict(strRestriction)
    oResItems.Sort "[Start]"
    oResItems.IncludeRecurrences = True
    For intCnt = oResItems.Count To 1 Step -1
        Set oAppt = oResItems.Item(intCnt)
        ' delete PTO entries
        If InStr(1, oAppt.Subject, "PTO:", vbTextCompare) > 0 Then
            oAppt.Delete
        End If
    Next
End Sub

Open in new window

0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.