How to Auto Archive Expired Items when Your Outlook File Is Larger Than a Specific Size

You may wish Outlook to auto archive expired items when your Outlook data file exceeds a specific size limit. Though there is not such a native feature, you still can get it by the means introduced in this post.

As we all know, the larger Outlook file is, the more vulnerable the file will be. So, it is necessary for you to always keep your Outlook file in small size. For instance, you can use the following method to auto archive expired items when Outlook file is larger than a specific size.Auto Archive Expired Items when Your Outlook File Is Larger Than a Specific Size

Auto Archive Expired Items when Outlook File Is Larger Than a Specific Size

  1. At first, in Outlook VBA editor, put the VBA code below into the “ThisOutlookSession” project.
'Occurs on Outlook startup
Sub Application_Startup()
    Call AutoArchiveExpiredItems_TooLargeOutlookFile
End Sub

Sub AutoArchiveExpiredItems_TooLargeOutlookFile()
    Dim objOutlookFile As Outlook.Folder
    Dim objFolder As Outlook.Folder
    Dim lTotalSize As Long
 
    lTotalSize = 0
    'Alter "John Smith" to the display name of your own Outlook file
    Set objOutlookFile = Outlook.Application.Session.Folders("John Smith")
    Call CountFileSize(objOutlookFile.Folders, lTotalSize)
 
    lTotalSize = (lTotalSize / 1024) / 1024
    'If Outlook file is larger than 20 MB
    'Modify "50" as per your needs
    If lTotalSize > 50 Then
       Call ArchiveExpiredItems(objOutlookFile)
    End If
End Sub
 
Sub CountFileSize(objFolders As Outlook.Folders, lFolderSize As Long)
    Dim objItem As Object
    Dim objSubFolder As Outlook.Folder
 
    'Count the size of folders
    For Each objFolder In objFolders
         For Each objItem In objFolder.Items
             lFolderSize = lFolderSize + objItem.Size
         Next

         If objFolder.Folders.Count > 0 Then
            Call CountFileSize(objFolder.Folders, lFolderSize)
         End If
    Next
End Sub

Sub ArchiveExpiredItems(objOutlookFile As Outlook.Folder)
    Dim objArchiveFile As Outlook.Folder
 
    'Change the path to your Archive Outlook file
    Application.Session.AddStore "C:\Users\Test\Documents\Outlook Files\Archives.pst"
    'Change "Archives" to the file display name in navigation pane
    Set objArchiveFile = Application.Session.Folders("Archives")
 
    'Loop all folders recursively
    Call ProcessFolders(objOutlookFile.Folders, objArchiveFile)
End Sub

Sub ProcessFolders(objFolders As Outlook.Folders, objArchiveFile)
    Dim objFolder As Outlook.Folder
    Dim objItem As Object
    Dim objArchiveFolder as Outlook.Folder
 
    'Move expired items to "Archives"
    For Each objFolder In objFolders
        If objFolder.DefaultItemType = olMailItem Then
           Set objArchiveFolder = objArchiveFile.Folders("Emails")

           For Each objItem In objFolder.Items
               If TypeName(objItem) = "MailItem" Or TypeName(objItem) = "MeetingItem" Then
                  If objItem.ExpiryTime < Now Then
                     objItem.Move objArchiveFolder
                  End If
               End If
           Next
 
           If objFolder.Folders.Count > 0 Then
              Call ProcessFolders(objFolder.Folders, objArchiveFile)
           End If
        ElseIf objFolder.DefaultItemType = olAppointmentItem Then
           Set objArchiveFolder = objArchiveFile.Folders("Calendar")

           objFolder.Items.SetColumns ("End")
           For Each objItem In objFolder.Items
               If (objItem.Start < Date) And (objItem.End < Date) Then
                   objItem.Move objArchiveFolder
               End If
           Next
 
           If objFolder.Folders.Count > 0 Then
              Call ProcessFolders(objFolder.Folders, objArchiveFile)
           End If
        ElseIf objFolder.DefaultItemType = olTaskItem Then
           Set objArchiveFolder = objArchiveFile.Folders("Tasks")

           objFolder.Items.SetColumns ("DueDate")
           For Each objItem In objFolder.Items
               If objItem.DueDate < Date Then
                  objItem.Move objArchiveFile
                End If
           Next
 
           If objFolder.Folders.Count > 0 Then
              Call ProcessFolders(objFolder.Folders, objArchiveFile)
           End If
        End If
    Next
End Sub

VBA Code - Auto Archive Expired Items when Outlook File Is Larger Than a Specific Size

  1. After that, restart your Outlook to activate this macro.
  2. Since then, every time when Outlook starts, the macro will check the Outlook file size. If it is larger than the specific size, Outlook will auto archive the expired items.Expired Items Archived

Keep Outlook File in Small Size

Protecting Outlook file is difficult, especially when Outlook file is too large. Hence, you ought to monitor Outlook file size all the time. Otherwise, if Outlook file gets damaged, you will need to take aid of an experienced and reliable fix tool, such as DataNumen Outlook Repair, which can repair PST file in a jiffy.

Author Introduction:

Shirley Zhang is a data recovery expert in DataNumen, Inc., which is the world leader in data recovery technologies, including corrupt sql and outlook repair software products. For more information visit www.datanumen.com

Comments are closed.