Delete of Outlook Calendar
Job meeting are often organize using Outlook Calendar. So during the year there could be a lot of appointment in the "Calendar". Here it is a code to move the appointment into the "Delete" folder. So after you have only to select all and delete permanently from Outlook.
Dim risp, a, myData, MyOL, objNS, objFolder, MyListItemsCalendar, colFilteredItems
a = ""
risp = ""
myData = InputBox("Insert the date from which to delete Calendar elements","Insert of Date", date)
if myData = "" then
Set MyOL = CreateObject("Outlook.Application")
Set objNS = MyOL.GetNameSpace("MAPI")
Set objFolder = objNS.GetDefaultFolder(9) 'Calendar
'load all calendar elements
Set MyListItemsCalendar = objFolder.Items
'filter all elements that have date < myData (input one)
Set colFilteredItems = MyListItemsCalendar.Restrict("[Start] < '" & myData & "'")
if colFilteredItems.Count > 0 then
risp = msgbox("I'm going to move to the delete folder " & colFilteredItems.Count & " calendar elemtents " & vbNewLine & _
"with date < " & myData & "!!!" & vbNewLine & vbNewLine & _
"Are you sure you want to delete them?" & vbNewLine , vbOkCancel + vbSystemModal + vbExclamation, "Confirm Calendar Elements Deletion")
if risp <> vbOK then
for i = colFilteredItems.Count to 1 step - 1
a = a & vbnewline & colFilteredItems.item(i).Subject & " - " & colFilteredItems.item(i).Start
msgbox "These calendar appointment have been moved into delete folder: " & vbNewLine & a, vbInformation + vbSystemModal, "Deletion Result"
msgbox "No element found before " & myData, vbExclamation + vbSystemModal, "No Elements"
set ColFilteredItems = Nothing
set MyListItemsCalendar = Nothing
set objFolder = Nothing
set objNS = Nothing
set MyOL = Nothing