Sub CancApt()
Dim olkFld As Outlook.Folder, _
olkLst As Outlook.Items, _
olkItemsInDateRange As Outlook.Items, _
olkApt As Outlook.AppointmentItem, _
strRestriction As String, _
intCnt As Integer, _
intIdx As Integer, _
daStart As Date, _
daEnd As Date
'Enter a start and end date'
daStart = (DateAdd("d", -7, Date))
daEnd = (DateAdd("d", 60, Date))
'Construct a filter for the date range.
strRestriction = "[Start] >= '" & daStart _
& "' AND [End] <= '" & daEnd & "'"
'Select calendar items in current folder
intAnswer = MsgBox("Have you selected the calendar?", vbYesNo, "Wait")
If intAnswer = vbYes Then
Else
GoTo EndMacro
End If
Set olkFld = Application.ActiveExplorer.CurrentFolder
Set olkLst = olkFld.Items
'To include recurring appointments, sort by using the Start property.
olkLst.IncludeRecurrences = True
olkLst.Sort "[Start]"
'Restrict the Items collection.
Set olkItemsInDateRange = olkLst.Restrict(strRestriction)
'Loop to count the items'
For Each olkApt In olkItemsInDateRange
intCnt = intCnt + 1
Next
'Loop to process the items'
For intIdx = intCnt To 1 Step -1
Set olkApt = olkItemsInDateRange(intIdx)
If Left(olkApt.Subject, 9) = "Canceled:" Then
olkApt.Delete
End If
Next
EndMacro:
Set olkFld = Nothing
Set olkLst = Nothing
Set olkApt = Nothing
MsgBox "Purge complete.", vbInformation + vbOKOnly, "Purge Canceled Appointments"
End Sub
|