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

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

  • Comments 0

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 :)

Leave a Comment
  • Please add 7 and 2 and type the answer here:
  • Post