Autoarchivage automatique des sous-dossiers

Bonjour/soir,

Si vous vouliez une réponse simple c'est perdu !-) En Vba, c'est pas
possible!
Ci-dessous la réponse que j'ai eu sur un forum en anglais.

"Eric Legault [MVP - Outlook]" <elegaultZZZ@REMOVEZZZmvps.org> a écrit dans
le message de news:OuAHLrIKEHA.1312@TK2MSFTNGP12.phx.gbl...

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>".

--
Eric Legault - B.A, MCP, MCSD, Outlook MVP
--------------------------------------------------
Job: http://www.imaginets.com
Blog: http://blogs.officezealot.com/legault/

Avec cette réponse j'ai trouvé un exemple de code en VC, juste pour mettre
la rétention ))-:
http://support.microsoft.com/default.aspx?scid=kb;en-us;194955

Si vous écrivez quelque chose, je suis preneur!

--
Grég


"jlmaillard" <anonymous@discussions.microsoft.com> a écrit dans le message
de news:21dd01c4279b$7133a280$a501280a@phx.gbl...
Bonjour,

la fonction Propriétés / Autoarchivage d'un dossier n'est
pas répercutée dans ses sous-dossiers.
Je n'ai trouvé aucune possibilité de le faire par défaut.
Je suis donc obligé de paramétrer chaque dossier dans tous
les niveaux de l'arborescence.

Quelqu'un aurait-il une solution? En VBA peu-être?

Je vous remercie par avance pour vos réponses

Bonjour/soir,

Si quelqu'un est toujours interessé pour mettre l'autoarchivage sur les
sous-dossiers, qui ne l'ont pas, comme sur le dossier parent. Ci-dessous le
code qui le fait avec cdo 1.21. J'ai pas tout testé, ni traité toutes les
erreurs. Vous aurez le message de sécurité autant de fois que vous avez un
répertoire contenant des adresses et, sans modification, cela ne s'occupe
que là où vous avez votre boîte de réception.

--
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
<---

"Grég" <greg@none.none> a écrit dans le message de
news:%23h0ya6IKEHA.620@tk2msftngp13.phx.gbl...

Bonjour/soir,

Si vous vouliez une réponse simple c'est perdu !-) En Vba, c'est pas
possible!
Ci-dessous la réponse que j'ai eu sur un forum en anglais.

"Eric Legault [MVP - Outlook]" <elegaultZZZ@REMOVEZZZmvps.org> a écrit
dans

...

"jlmaillard" <anonymous@discussions.microsoft.com> a écrit dans le message
de news:21dd01c4279b$7133a280$a501280a@phx.gbl...
Bonjour,

la fonction Propriétés / Autoarchivage d'un dossier n'est
pas répercutée dans ses sous-dossiers.
...

Quelqu'un aurait-il une solution? En VBA peu-être?

Je vous remercie par avance pour vos réponses