Delete Expired Items
Clearing out expired and completed items can be a chore, but not with VBA. The following sample code will go through the default Tasks and Inbox folder and clears out completed and expired items (respectively). It can be run periodically or as part of an event handler, to avoid the dreaded "your mailbox is over its size limit" warning.
Two versions of the code are listed here. The first one will go through the default Tasks and Inbox folders. The second will delete from the default Tasks folder and the mail folder of your choice. Both procedures use utility functions which are listed below, and both will also clear the Deleted Items folder.
Delete from default folders
This code iterates through the Tasks folder and deletes any task that is marked as complete. It checks the expiration date of emails in the Inbox, and then iterates through the Deleted Items folder and deletes those items again. This will permanently remove them.
On Error GoTo ErrorHandler
Dim olApp As Outlook.Application
Dim Itms As Outlook.Items
Dim taskItm As Outlook.TaskItem
Dim mailItm As Outlook.MailItem
Dim i As Long
Set olApp = GetOutlookApp
' Tasks folder
Set Itms = GetItems(GetNS(olApp), olFolderTasks)
For i = Itms.Count To 1 Step -1
If IsTask(Itms.Item(i)) Then
Set taskItm = Itms.Item(i)
If taskItm.Complete Then
taskItm.Delete
End If
End If
Next i
' Inbox folder
Set Itms = GetItems(GetNS(olApp), olFolderInbox)
For i = Itms.Count To 1 Step -1
If IsMail(Itms.Item(i)) Then
Set mailItm = Itms.Item(i)
If mailItm.ExpiryTime <= Now Then
mailItm.Delete
End If
End If
Next i
' clear out Deleted Items folder
Set Itms = GetItems(GetNS(olApp), olFolderDeletedItems)
For i = Itms.Count To 1 Step -1
Itms.Item(i).Delete
Next i
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Delete from chosen folder
This code will check if the folder holds mail items, in case the user selects a calendar or tasks folder.
On Error GoTo ErrorHandler
Dim olApp As Outlook.Application
Dim Itms As Outlook.Items
Dim fldr As Outlook.MAPIFolder
Dim taskItm As Outlook.TaskItem
Dim mailItm As Outlook.MailItem
Dim i As Long
Set olApp = GetOutlookApp
' Tasks folder
Set Itms = GetItems(GetNS(olApp), olFolderTasks)
For i = Itms.Count To 1 Step -1
If IsTask(Itms.item(i)) Then
Set taskItm = Itms.item(i)
If taskItm.Complete Then
taskItm.Delete
End If
End If
Next i
' pick folder
Set fldr = GetNS(olApp).PickFolder
' in case user cancels, or the folder does not hold mail items, exit
If fldr Is Nothing Then GoTo ProgramExit
If fldr.DefaultItemType <> olMailItem Then GoTo ProgramExit
Set Itms = fldr.Items
If Itms.Count = 0 Then GoTo ProgramExit
For i = Itms.Count To 1 Step -1
If IsMail(Itms.item(i)) Then
Set mailItm = Itms.item(i)
If mailItm.ExpiryTime <= Now Then
mailItm.Delete
End If
End If
Next i
' clear out Deleted Items folder
Set Itms = GetItems(GetNS(olApp), olFolderDeletedItems)
For i = Itms.Count To 1 Step -1
Itms.item(i).Delete
Next i
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Functions used by both procedures
These functions, among others, may be found at Utility Functions for use with Outlook 2003 VBA.
IsTask = (TypeName(itm) = "TaskItem")
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
Function GetItems(olNS As Outlook.NameSpace, folder As OlDefaultFolders) As Outlook.Items
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function
