Setting AutoArchive Settings for Subfolders – Macro and VBA

Outlook 2016 (Office 365 Pro) does not provide a method to change or duplicate AutoArchiving settings for all subfolders.  The only method provided is to set ALL folders to the defaults setup in advanced options or setting individual folder setting via properties of the folder.  This post will hopefully provide better control of Outlook Archiving via macros linked to VBA code.

If you have a complex filing system, for example /Product/Customers/Customer Name or /Year/Quarter/Month for organization, then modifying individual folders can be cumbersome and time consuming.

 

Also, if you do archive to a PST, there are time you will want to load a PST in a separate profile to “split” or “drain” old items out of it.  This entails modifying all the subfolders of a PST, doing the work, and then removing settings before loading your normal profile.  This may seem advanced, but in looking for solutions to set subfolder autoarchive settings, user have posted similar situations.  Hopefully this solution will assist them.

 

The Microsoft Outlook 2013 Developer Documentation.chm and the community were helpful in developing a solution.  The key was this article: How to: Save Auto-Archive Properties of a Folder in Solution Storage.  In the example AutoArchiving settings are called Aging properties.

 

NOTE:

Based on functional changes noted when testing, I found setting/reading all the properties worked best.  For example, if the Default property was not set correctly, the AgeFolder set to false would not clear turn off AutoArchiving settings in the Outlook folder’s properties.  Note when ready, you if the value has never been set (null), it will throw exception, thus the resume next.

 

Another helpful article in the CHM, How to: Enumerate Folders on All Stores. 

 

Note, CHM links by right clicking contents and using Jump to URL… in viewer.  Note, you may need to Unblock the CHM file using: Opening a CHM file produces: “navigation to the webpage was canceled”.  Some of the CHM pages are also online and can be found by searching.

 

Prerequisites:

You will want to customize your Outlook ribbon and make the Developer tab visible so you can access Macros and Visual Basic (VBA) commands.  Also, you will have to use Macro Security to set security to “Notification for all macros” since your macro will not be signed.

 

Disclaimer:

As is no warranty.  Use at own risk.  Verify you have backups of your data before using code to manipulate.  Understand risk of changing any settings before doing so.

 

To the code….

 

Macro Subs:

These are the main entry points and will show in the Macros command.  You can select a folder in tree, then run one of these to perform the implied action:

SetAgingPropertiesAllSubFoldersSameAsSelected

Select the top of a tree and execute to “copy” the selected folders AutoArchive settings to all subfolders

SetAgingPropertiesAllFoldersSameAsSelected

Select a folder in the tree and exectute to “copy” the selected folders AutoArchive settings to all subfolders AND all sibling folders and subfolders.  Just gets Parent and then works down from there.  This can be used to set all folders in a mailbox or PST.

TestGetAgingProps

Run on selected and display values in VBA editor.  For testing, could be removed or made private.

TestSetAgingProps

Run on selected folder and set that folder based on constants in code.  For testing, could be removed or made private.

 

Utility functions:

Used to do the work.

GetAgingProperties

Reads a folder’s aging properties.  Used to grab source folder’s settings.

SetAgingProperties

Sets a folder’s aging properties.  The key to the How To set AutoArchive settings.

SetAgingPropertiesSubFolders

Sets all AutoArchive setings for all subfolders of the passed folder.  The main subs call this to do the work of iterating the folder tree.

 

Load the code into Outlook:

Use Visual Basic command on Developer ribbon.  Use Insert > Module to create a new module.  Copy the below source code to the module.  Save.

 

To execute:

Select a folder.  Then use Macros command on Developer ribbon to execute preferred command.  I recommend starting at a tree with only one or two subfolders and verifying you get the results you are looking for.

 

Source code (I am not a huge advocate of line continuation, so to see pretty, copy to a code editor with good width…like the VBA editor):

 

'6 MAPI properties for aging items in a folder

Const PR_AGING_AGE_FOLDER = _

"http://schemas.microsoft.com/mapi/proptag/0x6857000B"

Const PR_AGING_DELETE_ITEMS = _

"http://schemas.microsoft.com/mapi/proptag/0x6855000B"

Const PR_AGING_FILE_NAME_AFTER9 = _

"http://schemas.microsoft.com/mapi/proptag/0x6859001E"

Const PR_AGING_GRANULARITY = _

"http://schemas.microsoft.com/mapi/proptag/0x36EE0003"

Const PR_AGING_PERIOD = _

"http://schemas.microsoft.com/mapi/proptag/0x36EC0003"

Const PR_AGING_DEFAULT = _

"http://schemas.microsoft.com/mapi/proptag/0x685E0003"

 

Function GetAgingProperties(oFolder As Outlook.Folder, AgeFolder As Boolean, DeleteItems As Boolean, FileName As String, Granularity As Integer, Period As Integer, Default As Integer) As Boolean

    If (oFolder Is Nothing) Then

        GetAgingProperties = False

        Exit Function

    End If

 

    On Error GoTo Aging_ErrTrap

   

   

    'Create or get solution storage in given folder by message class

    Set oStorage = oFolder.GetStorage("IPC.MS.Outlook.AgingProperties", olIdentifyByMessageClass)

    Set oPA = oStorage.PropertyAccessor

   

    ' Properties may be NULL and thus except out!

    On Error Resume Next

    

    AgeFolder = oPA.GetProperty(PR_AGING_AGE_FOLDER)

    'Get the 5 aging properties in the solution storage only if aging set!

    Granularity = oPA.GetProperty(PR_AGING_GRANULARITY)

    DeleteItems = oPA.GetProperty(PR_AGING_DELETE_ITEMS)

    Period = oPA.GetProperty(PR_AGING_PERIOD)

    FileName = oPA.GetProperty(PR_AGING_FILE_NAME_AFTER9)

    Default = oPA.GetProperty(PR_AGING_DEFAULT)

    

    GetAgingProperties = True

    Exit Function

 

Aging_ErrTrap:

    Debug.Print Err.Number, Err.Description

    GetAgingProperties = False

End Function

 

Function SetAgingProperties(oFolder As Outlook.Folder, AgeFolder As Boolean, DeleteItems As Boolean, FileName As String, Granularity As Integer, Period As Integer, Default As Integer) As Boolean

    Dim oStorage As StorageItem

    Dim oPA As PropertyAccessor

   

    ' Valid Period:

    ' 1-999

    '

    ' Valid Granularity:

    ' 0=Months, 1=Weeks, 2=Days

    '

    ' Valid Default:

    ' 0=All settings do not use a default setting

    ' 1=Only the file location is defaulted

    ' "Archive this folder using these settings" and

    ' "Move old items to default archive folder" are checked

    ' 3=All settings are defaulted

    ' "Archive items in this folder using default settings" is checked

   

    If (oFolder Is Nothing) Or (Granularity < 0 Or Granularity > 2) Or (Period < 1 Or Period > 999) Or (Default < 0 Or Default = 2 Or Default > 3) Then

        SetAgingProperties = False

    End If

 

    On Error GoTo Aging_ErrTrap

   

    'Create or get solution storage in given folder by message class

    Set oStorage = oFolder.GetStorage("IPC.MS.Outlook.AgingProperties", olIdentifyByMessageClass)

    Set oPA = oStorage.PropertyAccessor

   

    'Set other 6 aging properties in the solution storage only if aging!

    oPA.SetProperty PR_AGING_AGE_FOLDER, AgeFolder

    oPA.SetProperty PR_AGING_GRANULARITY, Granularity

    oPA.SetProperty PR_AGING_DELETE_ITEMS, DeleteItems

    oPA.SetProperty PR_AGING_PERIOD, Period

    oPA.SetProperty PR_AGING_FILE_NAME_AFTER9, FileName

    oPA.SetProperty (PR_AGING_DEFAULT), Default

   

    'Save changes as hidden messages to the associated portion of the folder

    oStorage.Save

   

    SetAgingProperties = True

    Exit Function

 

Aging_ErrTrap:

    Debug.Print Err.Number, Err.Description

    SetAgingProperties = False

End Function

 

Private Function SetAgingPropertiesSubFolders(ByVal oFolder As Outlook.Folder, AgeFolder As Boolean, DeleteItems As Boolean, FileName As String, Granularity As Integer, Period As Integer, Default As Integer) As Boolean

    Dim folders As Outlook.folders

    Dim Folder As Outlook.Folder

    Dim foldercount As Integer

   

   

    If (oFolder Is Nothing) Then

        SetAgingPropertiesSubFolders = False

    End If

   

    On Error GoTo Aging_ErrTrap

    

   

    Set folders = oFolder.folders

    foldercount = folders.Count

    'Check if there are any folders below oFolder

    If foldercount Then

        For Each Folder In folders

            Debug.Print (Folder.FolderPath)

            If SetAgingProperties(Folder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default) Then

                If Not SetAgingPropertiesSubFolders(Folder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default) Then

                    SetAgingPropertiesSubFolders = False

                    Exit Function

                End If

            Else

                SetAgingPropertiesSubFolders = False

                Exit Function

            End If

        Next

    End If

    SetAgingPropertiesSubFolders = True

    Exit Function

    

Aging_ErrTrap:

     Debug.Print Err.Number, Err.Description

     SetAgingPropertiesSubFolders = False

End Function

 

Sub SetAgingPropertiesAllSubFoldersSameAsSelected()

    Dim oFolder As Outlook.Folder

   

    Dim AgeFolder As Boolean

    Dim DeleteItems As Boolean

    Dim FileName As String

    Dim Granularity As Integer

    Dim Period As Integer

    Dim Default As Integer

   

    ' Get Currently selected folder

    Set oFolder = Application.ActiveExplorer.CurrentFolder

    

    ' Get the aging/archiving settings

    If GetAgingProperties(oFolder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default) Then

        ' Set all subfolders the same

        If Not SetAgingPropertiesSubFolders(oFolder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default) Then

            MsgBox "Error: Could not set aging/archive for all subfolders", vbCritical, "Set Archive Settings Error"

        End If

    End If

End Sub

 

' Set all folders the same  --- NOTE: The ROOT is hard coded to use defaults..so this allows getting everything in a mailbox.

Sub SetAgingPropertiesAllFoldersSameAsSelected()

    Dim oFolder As Outlook.Folder

   

    Dim AgeFolder As Boolean

    Dim DeleteItems As Boolean

    Dim FileName As String

    Dim Granularity As Integer

    Dim Period As Integer

    Dim Default As Integer

   

    ' Get Currently selected folder

    Set oFolder = Application.ActiveExplorer.CurrentFolder

    

    ' Get the aging/archiving settings

    If GetAgingProperties(oFolder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default) Then

        ' Set all folders the same  --- NOTE: The ROOT is hard coded to use defaults..so this allows getting everything in a mailbox.

        If Not SetAgingPropertiesSubFolders(oFolder.Parent, AgeFolder, DeleteItems, FileName, Granularity, Period, Default) Then

            MsgBox "Error: Could not set aging/archive for all subfolders", vbCritical, "Set Archive Settings Error"

        End If

    End If

End Sub

 

Sub TestGetAgingProps()

    Dim oFolder As Outlook.Folder

    Dim AgeFolder As Boolean

    Dim DeleteItems As Boolean

    Dim FileName As String

    Dim Granularity As Integer

    Dim Period As Integer

    Dim Default As Integer

   

   

    Set oFolder = Application.ActiveExplorer.CurrentFolder

   

    If GetAgingProperties(oFolder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default) Then

        Debug.Print "SetAgingProperties OK"

       

        Debug.Print "Folder: " & oFolder.FolderPath

        Debug.Print "AgeFolder: " & AgeFolder

        Debug.Print "DeleteItems: " & DeleteItems

        Debug.Print "FileName: " & FileName

        Debug.Print "Granularity: " & Granularity

        Debug.Print "Period: " & Period

        Debug.Print "Default: " & Default

       

    Else

        Debug.Print "SetAgingProperties Failed"

    End If

End Sub

 

Sub TestSetAgingProps()

    Dim oFolder As Outlook.Folder

   

    Set oFolder = Application.ActiveExplorer.CurrentFolder

   

    If SetAgingProperties(oFolder, False, False, "", 0, 6, 1) Then

        Debug.Print "SetAgingProperties OK"

    Else

        Debug.Print "SetAgingProperties Failed"

    End If

End Sub

 

 

Discussion Info


Last updated August 15, 2019 Views 685 Applies to: