'Delete old calendar items in Outlook.
'Recurring items will not be deleted.
'Items with end date less than the mentioned, would be deleted.
On Error resume Next
err.clear
Public intDel
Public Action
Sub calendarDel()
Dim i
Dim lngCount
Dim nms
Dim objFolder
Dim objItems
Dim objItem
Action = InputBox("Thanks for Using Calender Items deletion tool, Enter 1 to continue")
If Action = 1 then
'Set reference to default Calendar folder
Set ot = CreateObject("Outlook.Application")
Set nms = ot.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(9)
Set itms = fld.Items
lngCount = itms.Count
dtEnd = InputBox("Enter date in mm/dd/yyyy format")
intDel = 0
For Each itm in itms
i = i + 1
dtOrgEnd = itm.End
blFlagday = DateDiff("d", dtEnd,dtOrgEnd)
If blFlagday < 1 Then
If not(itm.IsRecurring) Then
itm.delete
intDel = intDel + 1
End If
intnotDel = intnotDel + 1
End If
Next
Else
MsgBox "Items not deleted"
End If
End Sub
'Procedure call to execute the calendar item delete function.
calendarDel()
' Notification on the number of calendar items deleted.
If Action = 1 then
msgbox "Number of calender items deleted = "& intDel
Else
msgbox "Number of calender items not deleted = "& intnotDel
End If
No comments:
Post a Comment