Outlook Deleting Recurring Appointments

[mikej28621]

In the January 2001 Windows IT Pro by Sue Mosher. She gives some code to Deleting Recurring Appointments and how to purge only items that occurred before a specific date in MS Outlook.

'Attribute VB_Name = "basPurgeCalendarFolder"
' place in an Outlook 2000 VBA module
' call this function from a subroutine that can pass
' to it a MAPIFolder object. For testing, see the
' TestPurgeCalendarFolder subroutine below.
Function PurgeCalendarFolder(objFolder As MAPIFolder) As String
Dim colItems As Items
Dim colOldItems As Items
Dim objItem As AppointmentItem
Dim strRes As String
Dim intCount As Integer
Dim strRestrict As String

' make sure this is a Calendar folder
If objFolder.DefaultItemType = olAppointmentItem Then
Set colItems = objFolder.Items

' get all the recurrences
colItems.Sort "[Start]"
colItems.IncludeRecurrences = True

' set optional restriction
strRestrict = GetRestrictDate(objFolder.Name)
If strRestrict <> "" Then
strRestrict = "[End] < " & Chr(34) & _
Format(strRestrict, "mmm dd, yyyy") & Chr(34)
Set colOldItems = colItems.Restrict(strRestrict)
End If

' perform deletions
Set objItem = colOldItems.GetFirst
Do Until objItem Is Nothing
Debug.Print objItem.End
objItem.Delete
intCount = intCount + 1
Set objItem = colOldItems.GetNext
Loop
End If

' report back to calling procedure
If intCount > 0 Then
strRes = Format(intCount) & " items purged"
Else
strRes = "no items purged"
End If

PurgeCalendarFolder = strRes

Set objItem = Nothing
Set colItems = Nothing
Set colOldItems = Nothing
End Function

Function GetRestrictDate(strFolderName As String) As String
Dim strMsg As String
Dim strTitle As String
Dim strResponse As String

' build prompts
strMsg = "Purge items that end before what date? " & _
vbCrLf & vbCrLf & _
"(Leave blank to purge all items from the folder.)"
strTitle = "Purge the " & strFolderName & " folder"

' display input box
strResponse = InputBox(strMsg, strTitle)
If strResponse = "" Or IsDate(strResponse) Then
GetRestrictDate = strResponse
Else
strResponse = GetRestrictDate(strFolderName)
End If

End Function


' for testing only
' shows the results of the purge in the Immediate window
Sub TestPurgeCalendarFolder()
Dim objOutlook As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder

Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
If Not objFolder Is Nothing Then
Debug.Print PurgeCalendarFolder(objFolder)
End If

Set objFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
End Sub

The code works but it only deletes some of the items. If you run it again it deletes a few more. I have looked over the code and can't find the error. I am running Outlook 2003 so I guessing it might be a version difference.

Any thoughts?

Many thanks

 

[mikej28621]

colItems, olOldItems appear to have the same number of items and it appears there is a failure in the statement

Do Until objItem Is Nothing

but I am not sure what else I can reference.

Thanks

 

[VBAjedi]

If I was gonna guess, I'd say that it's skipping the item that is after each one it deletes. Is that correct? I don't work with Outlook much, and I don't have the time to test this, but something like this might work for the Delete portion of the code:

        ' perform deletions
        For Each objItem in colOldItems
            Debug.Print objItem.End
            objItem.Delete
            intCount = intCount + 1
        Next objItem

Post back and let me know. .

VBAjedi

 

[mikej28621]

I wound up just putting it in a loop and letting it run till it deletes them all. Still would like an alternate suggestion.

Problem has something to do with "Do Until objItem Is Nothing" sees nothing when it should not.

Thanks