Setting AutoArchive properties on a folder hierarchy in Outlook 2007
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:
- 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
- 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 = "https://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 ""
' https://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