Is there anything more fun than writing custom VBA macros to solve a problem you face in your favorite app?  Actually, I'm sure there's lots that's more fun.  But, since I went through the pain of figuring this out, I figured I'd post here for posterity and see if anyone else found it useful.

 The problem I faced was how to handle RSS feeds in Outlook 2007.  I love integrated RSS, but I hate filling up my server quota with tons of RSS items.  If I haven't read an RSS item after two weeks, it probably means I don't care about it and it can get permanently deleted.  AutoArchive would be great for this, except for two problems:

  1. you can only have one autoArchive default setting, and a default of "permanently delete everything after two weeks" isn't what I want for the rest of my inbox
  2. Outlook UI offers no way to recursively apply settings down a folder hierarchy.  So if you have 100 folders for RSS feeds, you have to click and update the properties on each one.

My solution?  A little macro to read the settings off a folder, then recursively apply those settings to all child folders.  You'd think this would be easy, and in fact the Outlook team wrote a nice help article that gets you 90% of the way there.  Unfortunatley, the help article is filed under "Auto-Archive", so if you search for "AutoArchive" as it appears in the Outlook UI, you don't find anything.  It took me a couple days of playing around with a MAPI store viewer and reading through old MAPI C++ docs to figure out how this all works.  In brief:

Folder archiving properties are not actually stored as properties on the folder item.  Instead, they are stored on a hidden item inside the folder of message class "IPC.MS.Outlook.AgingProperties".  Hidden items, by the way, are known in the old MAPI parlance as Associated Items (GetContentsTable(MAPI_ASSOCIATED)).  Also, in MAPI-ville, archiving is known as Aging, so all the properties reference aging rather than archiving.  Once you have found the item with the message class, there are 6 properties that seem to govern server archiving behavior.  They are documented in the code below, but not anywhere else as far as I can tell.

Caveat: This is VBA code for Outlook 2007, not nice VSTO managed code, and running it requires you to lower Outlook's macro security settings.  What's more, I'm sure that this is not best practice VBA code writing, is full of errors and bad assumptions, and has terrible error handling.  I'm dead certain that this is not a best practice example of automating Outlook.  That having been said, it worked okay in the limited scenario for which it was designed.

 

Option Explicit

'------------------------------------------------------------------------------
'
' Hex values for the Exchange properties that govern aging / archiving
'
'------------------------------------------------------------------------------
Public Const hexPR_AGING_AGE_FOLDER = &H6857000B ' BOOL Enable aging aka Archive for this folder: True = Enabled False = Disabled
Public Const hexPR_AGING_GRANULARITY = &H36EE0003 'LONG Aging granularity: 0 = Months 1 = Weeks 2 = Days
Public Const hexPR_AGING_PERIOD = &H36EC0003 ' LONG, duration from 1 to 999 (combined with AGING GRANULARITY)
Public Const hexPR_AGING_DELETE_ITEMS = &H6855000B ' BOOL FALSE = archive, TRUE = permanently delete
Public Const hexPR_AGING_FILE_NAME_AFTER9 = &H6859001E ' STRING Path and filename of archive file for Exchange version > Exchange 9
Public Const hexPR_AGING_DEFAULT = &H685E0003 ' LONG values unclear, seems like 3=do not archive, 1=archive according to defaults, 0=custom settings
' the values below are not relevant to folder settings
'Public Const hexPR_AGING_FILE_NAME9_AND_PREV = &H6856001E ' STRING Path and filename of archive file for Exchange version <= Exchange 9
'Public Const hexPR_AGING_DONT_AGE_ME = &H6858000B ' BOOL
'Public Const hexPR_AGING_WHEN_DELETED_ON_SERVER = &H685B000B ' BOOL
'Public Const hexPR_AGING_WAIT_UNTIL_EXPIRED = &H685C000B ' BOOL
'Public Const hexPR_AGING_VERSION = &H685D0003 ' LONG

' Properties for aging granularity
Public Const AG_MONTHS = 0
Public Const AG_WEEKS = 1
Public Const AG_DAYS = 2

Public Const strProptagURL As String = "http://schemas.microsoft.com/mapi/proptag/0x"

'------------------------------------------------------------------------------
'
' String values for the Exchange properties that govern aging / archiving
'
'------------------------------------------------------------------------------
Public Const strPR_AGING_AGE_FOLDER As String = strProptagURL + "6857000B"
Public Const strPR_AGING_PERIOD As String = strProptagURL + "36EC0003"
Public Const strPR_AGING_GRANULARITY As String = strProptagURL + "36EE0003"
Public Const strPR_AGING_DELETE_ITEMS As String = strProptagURL + "6855000B"
Public Const strPR_AGING_FILE_NAME_AFTER9 As String = strProptagURL + "6859001E"
Public Const strPR_AGING_DEFAULT As String = strProptagURL + "685E0003"
'Public Const strPR_AGING_FILE_NAME9_AND_PREV As String = strProptagURL + "6856001E"
'Public Const strPR_AGING_DONT_AGE_ME As String = strProptagURL + "6858000B"
'Public Const strPR_AGING_WHEN_DELETED_ON_SERVER As String = strProptagURL + "685B000B"
'Public Const strPR_AGING_WAIT_UNTIL_EXPIRED As String = strProptagURL + "685C000B"
'Public Const strPR_AGING_VERSION  As String = strProptagURL + "685D0003"

'------------------------------------------------------------------------------
'
' UpdateFolderTreeArchiveSettings
'
' Asks the user to choose a folder, reads that folder's auto-archive settings,
' and then applies those settings recursively to all child folders
'
'------------------------------------------------------------------------------
Sub UpdateFolderTreeArchiveSettings()
    Dim ns As NameSpace
    Dim oRootFolder As folder
    Dim oFold As folder
   
    Dim AgeFolder As Boolean, DeleteItems As Boolean, _
        FileName As String, Granularity As Integer, _
        Period As Integer, Default As Integer
   
    Set ns = Application.GetNamespace("MAPI")
    Set oRootFolder = ns.PickFolder
   
    GetCurrentAgingProperties oRootFolder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default

    RecursivelyApplyChanges oRootFolder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default


End Sub
'------------------------------------------------------------------------------
'
' RecursivelyApplyChanges
'
' The tail-recursive procedure
'
'------------------------------------------------------------------------------
Sub RecursivelyApplyChanges(oFolder As Outlook.folder, AgeFolder As Boolean, DeleteItems As Boolean, _
                                FileName As String, Granularity As Integer, _
                                Period As Integer, Default As Integer)

    Dim oCurFolder As folder
   
    ChangeAgingProperties oFolder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default
   
    For Each oCurFolder In oFolder.Folders
        RecursivelyApplyChanges oCurFolder, AgeFolder, DeleteItems, FileName, Granularity, Period, Default
    Next oCurFolder

End Sub

'------------------------------------------------------------------------------
'
' ChangeAgingProperties
'
' Cribbed mostly from help topic ""
' http://officebeta.iponet.net/client/helppreview.aspx?AssetID=HV100458931033&ns=OUTLOOK.DEV&lcid=1033&CTT=3&Origin=HV100433811033
'
' But fixed two apparent bugs
' 1) should use PR_AGING_FILE_NAME_AFTER9 for file name
' 2) set PR_AGING_DEFAULT, since that's what Oulook does when using the UI
'
'------------------------------------------------------------------------------
Function ChangeAgingProperties(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
   
    Debug.Print "Updating " + oFolder.Name
   
    'Valid Period 1-999
    'Valid Granularity 0=Months, 1=Weeks, 2=Days
    If (oFolder Is Nothing) Or _
    (Granularity < 0 Or Granularity > 2) Or _
    (Period < 1 Or Period > 999) Then
        ChangeAgingProperties = 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
   
    If Not (AgeFolder) Then
        oPA.SetProperty strPR_AGING_AGE_FOLDER, False
    Else
        'Set the 5 aging properties in the solution storage
        oPA.SetProperty strPR_AGING_AGE_FOLDER, True
        oPA.SetProperty strPR_AGING_GRANULARITY, Granularity
        oPA.SetProperty strPR_AGING_DELETE_ITEMS, DeleteItems
        oPA.SetProperty strPR_AGING_PERIOD, Period
        If FileName <> "" Then
            oPA.SetProperty strPR_AGING_FILE_NAME_AFTER9, FileName
        End If
        oPA.SetProperty strPR_AGING_DEFAULT, Default
    End If
    'Save changes as hidden messages to the associated portion of the folder
    oStorage.Save
    ChangeAgingProperties = True
    Exit Function
   
Aging_ErrTrap:
    Debug.Print Err.Number, Err.Description
    ChangeAgingProperties = False
End Function

'------------------------------------------------------------------------------
'
' GetCurrentAgingProperties
'
' updates ByRef paramaters with values of the indicated folder
'
'------------------------------------------------------------------------------

Function GetCurrentAgingProperties(oFolder As Outlook.folder, _
                                ByRef AgeFolder As Boolean, ByRef DeleteItems As Boolean, _
                                ByRef FileName As String, ByRef Granularity As Integer, _
                                ByRef Period As Integer, ByRef Default As Integer) As Boolean
   
    Dim oStorage As StorageItem
    Dim oPA As PropertyAccessor
   
    Debug.Print "Fetching values for " + oFolder.Name
       
    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
   
    AgeFolder = oPA.GetProperty(strPR_AGING_AGE_FOLDER)
    Granularity = oPA.GetProperty(strPR_AGING_GRANULARITY)
    DeleteItems = oPA.GetProperty(strPR_AGING_DELETE_ITEMS)
    Period = oPA.GetProperty(strPR_AGING_PERIOD)
    FileName = oPA.GetProperty(strPR_AGING_FILE_NAME_AFTER9)
    Default = oPA.GetProperty(strPR_AGING_DEFAULT)

    PrintFolderSettings oFolder

    GetCurrentAgingProperties = True
   
    Exit Function
   
Aging_ErrTrap:
    Debug.Print Err.Number, Err.Description
    GetCurrentAgingProperties = False
End Function

'------------------------------------------------------------------------------
'
' PrintFolderSettings
'
' Utility procedure for printing current folder settings to console window
'
' Unlike the functions above, which get the archive settings row via GetStorage,
' this procedure uses a closer-to-the-metal approach of querying the folder for
' its hidden items.  No reason for this, other than I wanted to learn more about
' how these archive items really work.
'
' Note that this function assumes that the only hidden item in a folder is the
' IPC.MS.Outlook.AgingProperties item.
'
'------------------------------------------------------------------------------

Sub PrintFolderSettings(oFolder As Outlook.folder)
   
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
   
   
    Set oTable = oFolder.GetTable(TableContents:=olHiddenItems)
   
    Debug.Print ("Values for hidden items in folder " + oFolder.Name)
    
    
    oTable.Columns.RemoveAll
    'Specify desired properties
    With oTable.Columns
        .Add (strPR_AGING_PERIOD)
        .Add (strPR_AGING_GRANULARITY)
        .Add (strPR_AGING_DELETE_ITEMS)
        .Add (strPR_AGING_AGE_FOLDER)
        .Add (strPR_AGING_FILE_NAME_AFTER9)
        .Add (strPR_AGING_DEFAULT)
        '.Add (strPR_AGING_FILE_NAME9_AND_PREV)
        '.Add (strPR_AGING_DONT_AGE_ME)
        '.Add (strPR_AGING_WHEN_DELETED_ON_SERVER)
        '.Add (strPR_AGING_WAIT_UNTIL_EXPIRED)
        '.Add (strPR_AGING_VERSION)
    End With

    If Not (oTable Is Nothing) Then
        Do Until (oTable.EndOfTable)
            Set oRow = oTable.GetNextRow()
            Debug.Print ("PR_AGING_PERIOD: " + CStr(oRow(strPR_AGING_PERIOD)))
            Debug.Print ("PR_AGING_GRANULARITY: " + CStr(oRow(strPR_AGING_GRANULARITY)))
            Debug.Print ("PR_AGING_DELETE_ITEMS: " + CStr(oRow(strPR_AGING_DELETE_ITEMS)))
            Debug.Print ("PR_AGING_AGE_FOLDER: " + CStr(oRow(strPR_AGING_AGE_FOLDER)))
            Debug.Print ("PR_AGING_FILE_NAME_AFTER9: " + CStr(oRow(strPR_AGING_FILE_NAME_AFTER9)))
            Debug.Print ("PR_AGING_DEFAULT: " + CStr(oRow(strPR_AGING_DEFAULT)))
            'Debug.Print ("PR_AGING_FILE_NAME9_AND_PREV: " + CStr(oRow(strPR_AGING_FILE_NAME9_AND_PREV)))
            'Debug.Print ("PR_AGING_DONT_AGE_ME: " + CStr(oRow(strPR_AGING_DONT_AGE_ME)))
            'Debug.Print ("PR_AGING_WHEN_DELETED_ON_SERVER: " + CStr(oRow(strPR_AGING_WHEN_DELETED_ON_SERVER)))
            'Debug.Print ("PR_AGING_WAIT_UNTIL_EXPIRED: " + CStr(oRow(strPR_AGING_WAIT_UNTIL_EXPIRED)))
            'Debug.Print ("PR_AGING_VERSION: " + CStr(oRow(strPR_AGING_VERSION)))
        Loop
    End If

End Sub