autoarchivage et sous-dossiers : Outlook 2000

Bonjoir(c) Agnès

Le 28/07/2004 09:21 vous avez écrit ceci :

Bonjour,

Tout d'abbord, merci à JièL pour sa réponse à ma
précédente question...

Ce fut avec plaisir ;-)

J'ai une boite de réception avec de nombreux sous-
dossiers. Comment puis-je dire à Outlook d'archiver la
boite de réception et tous ses sous dossiers sans aller
dans les propriétés de chaque sous-dossier ? N'est-il pas
possible de prendre un dossier et l'ensemble de ses sous-
dossiers directement ?

Pas de chance, non. A ma connaissance, il faut les faire tous un par un

Lorsque j'archive, mon fichier d'archivage est assez
lourd (environ 13 Mo).

Pas trés lourd en fin de compte pour un fichier d'archive

Est-il possible de le réduire en taille de façon simple
tout en gardant le même nombre d'éléments ?

Oui : R0500 - Réduire la taille du .PST
http://faq.outlook.free.fr/?r_gerer_les_fichiers_d_outlook.htm#R0500

Encore merci,

--
La FAQ Outlook est la : http://faq.outlook.free.fr
JièL / Jean-Louis GOUBERT
Co-auteur de "Internet + de 1 000 trucs de pros" chez Micro Application
http://faq.outlook.free.fr/livreMA/internet_plus_de_1000_trucs_de_pros.htm

Bonjour/soir,


"JièL Goubert" <NoSpam_JieL.Goubert@LaPoste-Net.Nospam> a écrit dans le
message de news:OQ5HvQMdEHA.384@TK2MSFTNGP10.phx.gbl...

Bonjoir(c) Agnès

Le 28/07/2004 09:21 vous avez écrit ceci :

Bonjour,

Tout d'abbord, merci à JièL pour sa réponse à ma
précédente question...

Ce fut avec plaisir ;-)

C'est toujours pour le même !-)))

J'ai une boite de réception avec de nombreux sous-
dossiers. Comment puis-je dire à Outlook d'archiver la
boite de réception et tous ses sous dossiers sans aller
dans les propriétés de chaque sous-dossier ? N'est-il pas
possible de prendre un dossier et l'ensemble de ses sous-
dossiers directement ?

Pas de chance, non. A ma connaissance, il faut les faire tous un par un

Avec CDO 1.21 installé (dans les références ils doit y avoir Bibliothèque
CDO 1.21), la macro "CallSetAutoArchiving" ci-dessous devrait faire le
travail. Le principe est de propager les propriétés d'archivages définis
pour les dossiers parents à leurs descendants. Si un des descendant a déja
des propriétés définies actives elles ne seront pas modifiées et propagées
aux descendants.

<------
Option Explicit
Function blnIsFolderContacts(objFolder As MAPI.Folder) As Boolean
'+++
' blnIsFolderContacts
'
' Purpose:
' Test if the folder contains Contacts (avoid security messages)
'
' Return Values:
' Type : Boolean
' Description : True if the folder contains Contacts (using fields)
'
' Parameters:
' objFolder :
' Type : MAPI.Folder object
' Usage : Read Only
' Mechanism : By reference
' Description : The folder object to test
'
'
'
' Environment:
' Require CDO 1.21 or higher
'
' Side Effects:
' Do not raise Errors but can set Err object
'+++


' Const CdoPR_Contacts = &H36D10102
Const CdoPR_CONTAINER_CLASS = &H3613001E
Const CdoPR_CONTAINER_CLASS_Contacts = "IPF.Contact"
Dim objFields As MAPI.Fields
Dim objField As MAPI.Field


On Error Resume Next

blnIsFolderContacts = False
' Get fields of folders then loop as getting using property tag
' does not seem to work very well for folders

Set objFields = objFolder.Fields
Err.Clear

If Not objFields Is Nothing Then

For Each objField In objFields

If objField.ID = CdoPR_CONTAINER_CLASS Then
blnIsFolderContacts = _
(objField.Value = CdoPR_CONTAINER_CLASS_Contacts)
Exit For
End If
Next objField
End If

End Function
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
'+++
' lngSet1FolderAgingProperties
'
' 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 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 lngRet As Long
Dim blnIsContacts As Boolean
Dim strArchivingFile As String




' If objInFolder is not set then we have to initailize search at top of
the IPM subtree
If objInFolder Is Nothing Then
Set objSession = New MAPI.Session
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
blnIsContacts = blnIsFolderContacts(objRootFolder)
Else
' we are in a subfolder
blnIsContacts = blnIsFolderContacts(objInFolder)

' if we reset we ignore current aging property

If Not blnReset And Not blnIsContacts 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) And Not blnIsContacts 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
ElseIf Not blnIsContacts Then
' 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) And Not blnIsContacts 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

Bonjoir(c) Grég

Le 28/07/2004 20:37 vous avez écrit ceci :

Bonjour/soir,

Ce fut avec plaisir ;-)

C'est toujours pour le même !-)))

t'es pas jaloux au moins ? ;-))))))))))

Avec CDO 1.21 installé

[snip]
... beaucoup plus loin...
[snip]

End Sub

ouf... ben dis donc, juste pour propager les propriétés d'archivage d'un
dossier... Faut qu'il y en ai un gros paquet alors, parceque rien que le
temps de copier/coller tout le code et de remettre les fins de ligne aux
bons endroits, on a déjà mangé la grenouille comme on dit ;-)))))))))))

--
La FAQ Outlook est la : http://faq.outlook.free.fr
JièL / Jean-Louis GOUBERT
Co-auteur de "Internet + de 1 000 trucs de pros" chez Micro Application
http://faq.outlook.free.fr/livreMA/internet_plus_de_1000_trucs_de_pros.htm