Eric,
Thanks to show me the right way!
Below you'll find what I used to set Archiving properties on subfolders,
same as on parent folder, when these properties were not set.
I tested it on my OL2K, sp3 in Internet Mode with cdo 1.21 and it did the
job!
It raises security message when crawling thru a "contact" folder and error
handling is reduced to minimum, but you do not run that every day!
Hope this helps.
--
Grég
<---
Function lngSet1FolderAgingProperties(objFolder As MAPI.Folder, _
ByVal blnAgingEnabled As Boolean, _
Optional ByVal blnAgingDelete As Boolean =
False, _
Optional ByVal lngAgingPeriod As Long = 0, _
Optional ByVal lngAgingGranularity As Long =
12000, _
Optional ByVal strAgingFile As String = "") As
Long
'+++
' Set1FolderAgingProperties (SubProgramm)
'
' Purpose:
' Set Aging properties of the folder in objFolder.
'
' Return Values:
' Type : Long
' Description : Err.Number if problem occurs when setting one aging
prop.
' 0 if OK.
'
' Parameters:
' objFolder :
' Type : MAPI.Folder object
' Usage : Read Only
' Mechanism : By reference
' Description : The folder object where aging properties have to
be set
'
' blnAgingEnabled :
' Type : Boolean
' Usage : Modify
' Mechanism : By reference
' Description : Set to True if Autoarchiving is to be enabled
'
' blnAgingDelete :
' Type : Boolean (Optional, Default = False)
' Usage : Modify
' Mechanism : By reference
' Description : Set to True if delete items to archive
'
' lngAgingPeriod :
' Type : Long (Optional, Default = 0 / Month)
' Usage : Modify
' Mechanism : By reference
' Description : Set one of the three value AG_Months, AG_Weeks or
AG_DAYS.
' Determines the period (day, week, month),
multiplied by
' lngAgingGranularity, before archiving items in the
folder
'
' lngAgingGranularity :
' Type : Long (Optional, Default = 12000)
' Usage : Modify
' Mechanism : By reference
' Description : Determines the count, multiplied by
' lngAgingPeriod, before archiving items in the
folder
'
' strAgingFile :
' Type : String (Optional, Default = "")
' Usage : Modify
' Mechanism : By reference
' Description : Archiving full file name
'
'
' Environment:
' Require CDO 1.21 or higher
'
' Side Effects:
' Do not raise Errors but can set Err object
'+++
' Outlook AutoArchive property tags
Const CdoPR_AGING_FILENAME = &H6856001E
Const CdoPR_AGING_PERIOD = &H36EC0003
Const CdoPR_AGING_GRANULARITY = &H36EE0003
Const CdoPR_AGING_AGE_FOLDER = &H6857000B
Const CdoPR_AGING_DELETE_ITEMS = &H6855000B
' Const AG_MONTHS = 0
' Const AG_WEEKS = 1
' Const AG_DAYS = 2
Dim objMessages As MAPI.Messages
Dim objMessage As MAPI.Message
Dim objFields As MAPI.Fields
Dim objField As MAPI.Field
Dim blnOKSet As Boolean
On Error Resume Next
blnOKSet = False
' Get hidden messages collection where will get the message conatining
aging prop.
Set objMessages = Nothing
Set objMessages = objFolder.HiddenMessages
Err.Clear
If Not objMessages Is Nothing Then
' Get first folder
Set objMessage = objMessages.GetFirst
Err.Clear
While Not objMessage Is Nothing
If objMessage.Type = "IPC.MS.Outlook.AgingProperties" Then
Set objFields = objMessage.Fields
Err.Clear
If Not objFields Is Nothing Then
Set objField = Nothing
Set objField = objFields.Item(CdoPR_AGING_AGE_FOLDER)
If Not objField Is Nothing Then
objField.Value = blnAgingEnabled
Else
Err.Clear
objFields.Add CdoPR_AGING_AGE_FOLDER,
blnAgingEnabled
End If
Set objField = Nothing
Set objField = objFields.Item(CdoPR_AGING_PERIOD)
If Not objField Is Nothing Then
objField.Value = lngAgingPeriod
Else
Err.Clear
objFields.Add CdoPR_AGING_PERIOD, lngAgingPeriod
End If
Set objField = Nothing
Set objField = objFields.Item(CdoPR_AGING_GRANULARITY)
If Not objField Is Nothing Then
objField.Value = lngAgingGranularity
Else
Err.Clear
objFields.Add CdoPR_AGING_GRANULARITY,
lngAgingGranularity
End If
Set objField = Nothing
Set objField = objFields.Item(CdoPR_AGING_FILENAME)
If Not objField Is Nothing Then
objField.Value = strAgingFile
Else
Err.Clear
objFields.Add CdoPR_AGING_FILENAME, strAgingFile
End If
Set objField = Nothing
Set objField = objFields.Item(CdoPR_AGING_DELETE_ITEMS)
If Not objField Is Nothing Then
objField.Value = blnAgingDelete
Else
Err.Clear
objFields.Add CdoPR_AGING_DELETE_ITEMS,
blnAgingDelete
End If
blnOKSet = (Err.Number = 0)
End If
' We got what we wanted so we stop looping
objMessage.Update True, True
blnOKSet = blnOKSet And (Err.Number = 0)
Set objMessage = Nothing
Else
' not good type: get next message
Set objMessage = objMessages.GetNext
Err.Clear
End If
Wend
End If
If Not blnOKSet Then
' nothing done
If Err.Number <> 0 Then
' We got an Error
lngSet1FolderAgingProperties = Err.Number
Else
' Didi not fing an aging message
Set objMessage = objFolder.HiddenMessages.Add(, ,
"IPC.MS.Outlook.AgingProperties")
Set objFields = objMessage.Fields
With objFields
.Add CdoPR_AGING_AGE_FOLDER, blnAgingEnabled
.Add CdoPR_AGING_PERIOD, lngAgingPeriod
.Add CdoPR_AGING_GRANULARITY, lngAgingGranularity
.Add CdoPR_AGING_FILENAME, strAgingFile
.Add CdoPR_AGING_DELETE_ITEMS, blnAgingDelete
End With
objMessage.Update True, True
lngSet1FolderAgingProperties = Err.Number
End If
Else
lngSet1FolderAgingProperties = 0
End If
End Function
Sub Get1FolderAgingProperties(objFolder As MAPI.Folder, _
ByRef blnAgingEnabled As Boolean, _
Optional ByRef blnAgingDelete As Boolean, _
Optional ByRef lngAgingPeriod As Long, _
Optional ByRef lngAgingGranularity As Long, _
Optional ByRef strAgingFile As String)
'+++
' Get1FolderAgingProperties (SubProgramm)
'
' Purpose:
' Returns Aging properties of the folder in objFolder. If Aging
poperties are
' not enabled only the enabling property is meaningfull
'
' Parameters:
' objFolder :
' Type : MAPI.Folder object
' Usage : Read Only
' Mechanism : By reference
' Description : The folder object from wich aging properties have
to be returned
'
' blnAgingEnabled :
' Type : Boolean
' Usage : Modify
' Mechanism : By reference
' Description : Set to True if Autoarchiving is active
'
' blnAgingDelete :
' Type : Boolean (Optional, no default)
' Usage : Modify
' Mechanism : By reference
' Description : Set to True if delete items to archive
'
' lngAgingPeriod :
' Type : Long (Optional, Nodefault)
' Usage : Modify
' Mechanism : By reference
' Description : Set one of the three value AG_Months, AG_Weeks or
AG_DAYS.
' Determines the period (day, week, month),
multiplied by
' lngAgingGranularity, before archiving items in the
folder
'
' lngAgingGranularity :
' Type : Long (Optional, Nodefault)
' Usage : Modify
' Mechanism : By reference
' Description : Determines the count, multiplied by
' lngAgingPeriod, before archiving items in the
folder
'
' strAgingFile :
' Type : String (Optional, Nodefault)
' Usage : Modify
' Mechanism : By reference
' Description : Archiving full file name
'
'
' Environment:
' Require CDO 1.21 or higher
'
' Side Effects:
' Can raise Errors
'+++
' Outlook AutoArchive property tags
Const CdoPR_AGING_FILENAME = &H6856001E
Const CdoPR_AGING_PERIOD = &H36EC0003
Const CdoPR_AGING_GRANULARITY = &H36EE0003
Const CdoPR_AGING_AGE_FOLDER = &H6857000B
Const CdoPR_AGING_DELETE_ITEMS = &H6855000B
' Const AG_MONTHS = 0
' Const AG_WEEKS = 1
' Const AG_DAYS = 2
Dim objMessages As MAPI.Messages
Dim objMessage As MAPI.Message
Dim objFields As MAPI.Fields
Dim objField As MAPI.Field
' First initialize to not enabled
blnAgingEnabled = False
blnAgingDelete = False
lngAgingPeriod = 0
lngAgingGranularity = 0
strAgingFile = ""
' Get hidden messages collection where will get the message conatining
aging prop.
On Error Resume Next
Set objMessages = Nothing
Set objMessages = objFolder.HiddenMessages
On Error GoTo 0
If Not objMessages Is Nothing Then
For Each objMessage In objMessages
If objMessage.Type = "IPC.MS.Outlook.AgingProperties" Then
Set objFields = objMessage.Fields
If Not objFields Is Nothing Then
Set objField = Nothing
On Error Resume Next
Set objField = objFields.Item(CdoPR_AGING_AGE_FOLDER)
On Error GoTo 0
If Not objField Is Nothing Then
blnAgingEnabled = objField.Value
End If
' get other value only if Aging is enebled
If blnAgingEnabled Then
On Error Resume Next
Set objField = Nothing
Set objField = objFields.Item(CdoPR_AGING_PERIOD)
On Error GoTo 0
If Not objField Is Nothing Then
lngAgingPeriod = objField.Value
End If
On Error Resume Next
Set objField = Nothing
Set objField =
objFields.Item(CdoPR_AGING_GRANULARITY)
On Error GoTo 0
If Not objField Is Nothing Then
lngAgingGranularity = objField.Value
End If
On Error Resume Next
Set objField = Nothing
Set objField = objFields.Item(CdoPR_AGING_FILENAME)
On Error GoTo 0
If Not objField Is Nothing Then
strAgingFile = objField.Value
End If
On Error Resume Next
Set objField = Nothing
Set objField =
objFields.Item(CdoPR_AGING_DELETE_ITEMS)
On Error GoTo 0
If Not objField Is Nothing Then
blnAgingDelete = objField.Value
End If
End If
End If
' We got waht we wanted so we stop looping
Exit For
End If
Next objMessage
End If
End Sub
Sub SetAutoArchivingOnFolderTree(Optional objInFolder As MAPI.Folder =
Nothing, _
Optional ByRef blnReset As Boolean = False,
_
Optional ByVal blnDefAgingEnabled As
Boolean = False, _
Optional ByVal blnDefAgingDelete As Boolean
= False, _
Optional ByVal lngDefAgingPeriod As Long, _
Optional ByVal lngDefAgingGranularity As
Long, _
Optional ByVal strDefAgingFile As String)
'+++
' SetAutoArchivingOnFolderTree
'
' Purpose:
' Propagation of Archiving Properties on folder branches. If
objInfolder
' is Nothing then all the IPM tree containing the Inbox is searched.
' The aging properties from parameters are set on folder if this
folder have not
' aging properties set. Howewer if blnReset flag is True then aging
properties are
' set regardless on folder of their setting. The ObjInfolder Aging
properties are
' propagated to subfolders.
'
' Parameters:
' objInFolder :
' Type : MAPI.Folder object (Optional, Default = Nothing)
' Usage : Read Only
' Mechanism : By reference
' Description : The folder object from to which aging properties
have to
' be propagated. If Nothing then all IPM folder tree
must
' be searched
'
' blnReset :
' Type : Boolean (Optional, Default = False)
' Usage : Read Only
' Mechanism : By reference
' Description : If true objInFolder Aging properties are set from
parameters
' regardless of thier setting. If False objInFolder
Aging
' properties are set from parameters only if they
are not
' already enabled
'
' blnDefAgingEnabled :
' Type : Boolean (Optional, Default = False)
' Usage : Read Only
' Mechanism : By Value
' Description : Set to True if Autoarchiving has to be enabled
'
' blnDefAgingDelete :
' Type : Boolean (Optional, Default = False)
' Usage : Read Only
' Mechanism : By Value
' Description : Set to True if items to be deleted and not
archived
'
' lngDefAgingPeriod :
' Type : Long (Optional, Nodefault)
' Usage : Read Only
' Mechanism : By Value
' Description : Set one of the three value AG_Months, AG_Weeks or
AG_DAYS.
' Determines the period (day, week, month),
multiplied by
' lngAgingGranularity, before archiving items in the
folder
'
' lngDefAgingGranularity :
' Type : Long (Optional, Nodefault)
' Usage : Modify
' Mechanism : By reference
' Description : Determines the count, multiplied by
' lngAgingPeriod, before archiving items in the
folder
'
' strDefAgingFile :
' Type : String (Optional, Nodefault)
' Usage : Modify
' Mechanism : By reference
' Description : Archiving full file name to use
'
' Design:
' ATTENTION: No verification done on parameters. Invalid values or
inconstitencies will be
' propagated!!!!
'
' Environment:
' Requires CDO 1.21 or higher
'
' Side Effects:
' Can raise Errors
'+++
' Const CdoPR_FINDER_ENTRYID = &H35E70102
' Outlook AutoArchive property tags
' Const CdoPR_AGING_FILENAME = &H6856001E
' Const CdoPR_AGING_PERIOD = &H36EC0003
' Const CdoPR_AGING_GRANULARITY = &H36EE0003
' Const CdoPR_AGING_AGE_FOLDER = &H6857000B
' Const CdoPR_AGING_DELETE_ITEMS = &H6855000B
' Const AG_MONTHS = 0
' Const AG_WEEKS = 1
' Const AG_DAYS = 2
' Folder permissions property tags
'Const CDO_PR_RIGHTS = &H66390003
'Const CdoPR_ACCESS = &HFF40003
'Const MAPI_ACCESS_CREATE_ASSOCIATED = &H20
'Const MAPI_ACCESS_CREATE_CONTENTS = &H10
'Const MAPI_ACCESS_CREATE_HIERARCHY = &H8
'Const MAPI_ACCESS_READ = &H2
'Const MAPI_ACCESS_MODIFY = &H1
Dim objSession As New MAPI.Session
Dim objInfoStore As MAPI.InfoStore
' Dim objFinderFolder As MAPI.Folder
Dim objRootFolder As MAPI.Folder
Dim objFolders As MAPI.Folders
Dim objFolder As MAPI.Folder
' Dim strFinderEntryID As String
Dim blnArchivingEnabled As Boolean
Dim blnArchivingDelete As Boolean
Dim lngArchivingPeriod As Long
Dim lngArchivingGranularity As Long
Dim strArchivingFile As String
Dim lngRet As Long
' If objInFolder is not set then we have to initailize search at top of
the IPM subtree
If objInFolder Is Nothing Then
objSession.Logon "", "", False, False
Set objInfoStore = objSession.GetInfoStore(objSession.Inbox.StoreID)
' get the root folder of the IPM subtree not the Root of the message
store as commented below
Set objRootFolder = objInfoStore.RootFolder
' strFinderEntryID =
objInfostore.Fields.Item(CdoPR_FINDER_ENTRYID).Value
' Set objFinderFolder = objSession.GetFolder(strFinderEntryID,
objInfostore.ID)
' Set objRootFolder = objSession.GetFolder(objFinderFolder.FolderID,
objInfostore.ID)
Set objFolders = objRootFolder.Folders
Else
' we are in a subfolder
' if we reset we ignore current aging property
If Not blnReset Then
' Not reset so we get aging property as if exist nothing to
set
Call Get1FolderAgingProperties(objInFolder, _
blnArchivingEnabled, _
blnArchivingDelete, _
lngArchivingPeriod, _
lngArchivingGranularity, _
strArchivingFile)
End If
If Not blnArchivingEnabled Or blnReset Then
' Current folder aging prop do not exist so we set them with the ones
from parameters if exist (or reset)
If blnDefAgingEnabled Or blnReset Then
lngRet = lngSet1FolderAgingProperties(objInFolder, _
blnDefAgingEnabled, _
blnDefAgingDelete, _
lngDefAgingPeriod, _
lngDefAgingGranularity, _
strDefAgingFile)
If lngRet <> 0 Then
' not set so I should try to fix it..
lngRet = lngRet ' NOP for break point
End If
End If
Else
' Current folder aging prop exist so we set the new default
blnDefAgingEnabled = blnArchivingEnabled
blnDefAgingDelete = blnArchivingDelete
lngDefAgingPeriod = lngArchivingPeriod
lngDefAgingGranularity = lngArchivingGranularity
strDefAgingFile = strArchivingFile
End If
' we prepare to loop for next subfolder level
Set objFolders = objInFolder.Folders
End If
' Is there sub-folders ?
If Not objFolders Is Nothing Then
' Get first folder
Set objFolder = objFolders.GetFirst
' Loop through the folders collection and recurses
While Not objFolder Is Nothing
Call SetAutoArchivingOnFolderTree(objFolder, _
blnReset, _
blnDefAgingEnabled, _
blnDefAgingDelete, _
lngDefAgingPeriod, _
lngDefAgingGranularity, _
strDefAgingFile)
'Get next folder
Set objFolder = objFolders.GetNext
Wend
Set objFolders = Nothing
Set objFolder = Nothing
End If
End Sub
Sub CallSetAutoArchiving()
Call SetAutoArchivingOnFolderTree
End Sub
<----
Eric Legault said:
No, you didn't miss anything. AutoArchive settings are not exposed via the
Outlook Object Model. They are stored in a hidden message in the folder
titled "IPC.MS.Outlook.AgingProperties" that can only be accessed via the
HiddenMessages collection of a Folder object in CDO. Individual settings
are stored as MAPI Property Tags accessible through the Fields collection of
the Message object. An example is the PR_AGING_PERIOD field, which contains
the value for "Clean out items older than X <days/weeks/months>".
