We value your feedback.
Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!
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, _ intAnswer As String, _ daStart As Date, _ daEnd As Date 'Enter a start and end date' daStart = InputBox("Enter a start date.", "Purge Canceled Appointments Start", (DateAdd("d", -7, Date))) daEnd = InputBox("Enter an end date.", "Purge Canceled Appointments End", (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