I am trying to set the default autoarchive settings for user created folders
within Outlook 2003 using the code below yet I keep getting the error Object
doesn't support this property or method on the line: objMessage.Add
"IPC.MS.Outlook.AgingProperties". Does anyone know what is wrong here? I
would also like to change it to be recursive in case of subfolders. Any
revised sample code would be appreciated.

Thanks,
Lando
------------------------------------------------

Sub Arc()

' MAPI property tags for aging properties
Const CdoPR_AGING_PERIOD = &H36EC0003
Const CdoPR_AGING_GRANULARITY = &H36EE0003
Const CdoPR_AGING_PATH = &H6856001E
Const CdoPR_AGING_ENABLED = &H6857000B
Const CdoPR_AUTOARCHIVE_TYPE = &H685E0003
Const CdoPR_AGING_AGE_FOLDER = &H6857000B
Const CdoPR_CONTAINER_CLASS = &H3613001E

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

' Declare variables
Dim objSession As MAPI.Session
Dim objInfoStore As Object
'Dim objInboxFolder As MAPI.Folder
'Dim colFolders As MAPI.Folders


' Initialize variables
Set objSession = Nothing
Set objInboxFolder = Nothing

' Create CDO session and logon
Set objSession = New MAPI.Session

' CDO session logon
objSession.Logon "", "", ShowDialog:=True, NewSession:=False

Set objInfoStore = objSession.InfoStores.Item(1)
Set objRootFolder = objInfoStore.RootFolder
Set colFolders = objRootFolder.Folders

Set objFolCalendar = objSession.GetDefaultFolder(CdoDefaultFolderCalend ar)
Set objFolContacts = objSession.GetDefaultFolder(CdoDefaultFolderContac ts)
Set objFolDeleted =
objSession.GetDefaultFolder(CdoDefaultFolderDelete dItems)
Set objFolJournal = objSession.GetDefaultFolder(CdoDefaultFolderJourna l)
Set objFolNotes = objSession.GetDefaultFolder(CdoDefaultFolderNotes)
Set objFolSent = objSession.GetDefaultFolder(CdoDefaultFolderSentIt ems)
Set objFolTasks = objSession.GetDefaultFolder(CdoDefaultFolderTasks)
Set objFolInbox = objSession.GetDefaultFolder(CdoDefaultFolderInbox)
Set objFolOutbox = objSession.GetDefaultFolder(CdoDefaultFolderOutbox )


For Each objFolder In colFolders

' Get hidden message collection
Set objHiddenMessages = objFolder.HiddenMessages

' Loop through the hidden messages collection
For Each objMessage In objHiddenMessages


Select Case objFolder.ID
Case objFolInbox.ID
Case objFolOutbox.ID
Case objFolJournal.ID
Case objFolContacts.ID
Case objFolCalendar.ID
Case objFolDeleted.ID
Case objFolNotes.ID
Case objFolTasks.ID
Case objFolSent.ID
Case Else

If Not objMessage.Type = "IPC.MS.Outlook.AgingProperties" Then
objMessage.Add "IPC.MS.Outlook.AgingProperties"
End If

' Change the autoarchive mode (none,default,param)
objMessage.Fields.Item(CdoPR_AUTOARCHIVE_TYPE).Val ue = 0

' Change aging properties to 14 months/weeks/days
objMessage.Fields.Item(CdoPR_AGING_PERIOD).Value = 3

' Change aging granularity to days
objMessage.Fields.Item(CdoPR_AGING_GRANULARITY).Va lue = AG_MONTHS

' Change the path to the archive file
objMessage.Fields.Item(CdoPR_AGING_PATH).Value = "C:\Temp\archive.pst"

' Enable aging for this folder
objMessage.Fields.Item(CdoPR_AGING_ENABLED).Value = True

' Enable aging age for this folder
objMessage.Fields.Item(CdoPR_AGING_AGE_FOLDER).Val ue = True

' Update hidden message
objMessage.Update True, True

'End If
End Select
Next

Next
End Sub