Print Auto-Archive Settings

The Archive feature is used in Outlook to move old items to an archive file or to delete them. You can set the settings for each folder: Right click the folder name, then choose Settings, AutoArchive. It's easy to forget some folders. And there's no built-in feature to see a summary of all the settings.

The following macros print such a list to the debug window (ctrl+g) of the VBA editor. Launch the function, for instance, by pressing ALT+F8, then select the start folder. The settings will be printed for the start folder and all its subfolders. If you have set a folder to be archived and the folder doesn't use the default settings, then the name of the archive file will be printed, too.

The meaning of 'Default settings' for a folder can be do archive, do not archive, or delete. As you can get the default settings quickly from the Options dialog, more code shouldn't be necessary. For those who want to get these settings by code as well, you'll find them in the Registry under HKEY_CURRENT_USER/Software/Microsoft/Office/xx.0/Outlook/Preferences. Replace 'xx' by your Outlook version.

To get this sample running you need to install the Redemption, which is free for private users. After the installation set a reference on the Redemption * Library via Tools/References.

  How to add macros to Outlook

Public Sub PrintAutoArchiveSettings()
  Dim Session As Redemption.RDOSession
  Dim Folder As Redemption.RDOFolder
  
  Set Session = CreateObject("redemption.rdosession")
  'The following line works for OL 2003 and higher. For an older version
  'call Session.Logon instead
  Session.MAPIOBJECT = Application.Session.MAPIOBJECT
  
  Set Folder = Session.PickFolder
  If Folder Is Nothing Then Exit Sub
  
  GetAgingProperties Folder, 0
  LoopFolders Folder.Folders, True, 1
End Sub

Private Sub LoopFolders(Folders As Redemption.RDOFolders, _
  ByVal Recursive As Boolean, _
  ByVal Indent As Long _
)
  Dim Folder As Redemption.RDOFolder
  For Each Folder In Folders
    GetAgingProperties Folder, Indent
    If Recursive Then
      LoopFolders Folder.Folders, Recursive, Indent + 1
    End If
  Next
End Sub

Private Sub GetAgingProperties(Folder As Redemption.RDOFolder, ByVal Indent As Long)
  On Error Resume Next
  Dim Item As Redemption.RDOMail
  Dim msg$
  Const AGE_FOLDER As Long = &H6857000B
  Const DELETE_ITEMS As Long = &H6855000B
  Const FILE_NAME As Long = &H6859001E
  Const GRANULARITY As Long = &H36EE0003
  Const AGING_PERIOD As Long = &H36EC0003
  Const AGING_DEFAULT As Long = &H685E0003
  
  If Folder.DefaultMessageClass = "IPM.Configuration" Then Exit Sub

  msg = String(Indent, vbTab) & Folder.Name & ": "  
  Set Item = Folder.HiddenItems.Find("[MessageClass]='IPC.MS.Outlook.AgingProperties'")
  
  If Not Item Is Nothing Then
    If Item.Fields(AGE_FOLDER) = True Then
      Select Case Item.Fields(AGING_DEFAULT)
      Case 0, 1
        If Item.Fields(DELETE_ITEMS) = True Then
          msg = msg & "Delete items"
        Else
          msg = msg & "Archive items"
          If Item.Fields(FILE_NAME) Then
            msg = msg & " (" & Item.Fields(FILE_NAME) & ")"
          End If
        End If
      Case 3
        msg = msg & "Default settings"
      End Select
    ElseIf Item.Fields(AGING_DEFAULT) = 3 Then
      msg = msg & "Default settings"
    Else
      msg = msg & "Do not archive"
    End If
  Else
    msg = msg & "Do not archive"
  End If
  
  Debug.Print msg
End Sub