How to delete old items from .pst attached to Outlook using CDO1.21 programmatically?

If you would like to clear up some old items from the growing PST attached to you Outlook profile; then here is a sample VBA macro code snippet to accomplish the job using CDO 1.21.

NOTE: Following programming examples is for illustration only, without warranty either 'expressed or implied, including, but not limited to, the implied warranties of 'merchantability and/or fitness for a particular purpose. This sample code assumes that you 'are familiar with the programming language being demonstrated and the tools used to create 'and debug procedures. This sample code is provided for the purpose of illustration only 'and is not intended to be used in a production environment.

 'We need to add reference to Collaboration Data Objects, version 1.2.1 before running the VBA macro

 Sub RemoveAllOldItems()

     Dim ol As Outlook.Application

     Dim olns As Outlook.NameSpace

     Dim colStores As Outlook.Stores

     Dim oStore As Outlook.Store

     Dim oRoot As Outlook.Folder

     Dim ocal As Outlook.Folder

     Set ol = Application

     Set olns = ol.GetNamespace("MAPI")

     Set colStores = olns.Application.Session.Stores

      For Each oStore In colStores

         Set oRoot = oStore.GetRootFolder

         If oStore.ExchangeStoreType = 3 Then 'And oRoot = "Test" Then

             DeleteOldItems oRoot

             EnumerateFolders oRoot

         End If

      Next

 End Sub

 Public Function EnumerateFolders(ByVal objFld As Outlook.Folder)

     Dim folders As Outlook.folders

     Dim Folder As Outlook.Folder

     Dim foldercount As Integer

     Set folders = objFld.folders

     foldercount = folders.Count

     'Check if there are any folders below oFolder

     If foldercount Then

         For Each Folder In folders

             Debug.Print (Folder.FolderPath)

             DeleteOldItems Folder

             EnumerateFolders Folder

         Next

     End If

 End Function

 Public Function DeleteOldItems(ByVal objfl As Outlook.Folder)

     Dim oItems As Outlook.items

     Dim i As Long

     Set oItems = objfl.items

     Dim oRT As Date

     For i = oItems.Count To 1 Step -1

         oRT = oItems.Item(i).ReceivedTime

         'Checking for 4 months old items 

         If DateDiff("m", oRT, Now()) >= 4 Then

             Debug.Print "Old item found"

             'Uncomment the below line to delete this item

             'oItems.Item(i).Delete

         End If

     Next

 End Function

 

If you are running Outlook 2007 then you need to download and install CDO 1.21 @ Collaboration Data Objects, version 1.2.1

Hope this helps! Happy Holidays :)