Code VBA pour Archiver

Bonjour a tous

j'ai trouvé un code sur http://www.outlookcode.com

Celui-ci à l'avantage d'ouvrir un pst archives, déplace les anciens mails à
partir d'un dossier (dans l'exemple : éléments supprimés) puis refermes le
pst.


Code :

Option Explicit

''=======================================================================
'' Code for attaching my archive pst, moving older emails to
'' a specific folder within this pst and then detaching it.
''
'' In this example all items in the Deleted Items folder older than
'' 60 days are moved to my own archive file into the 'Deletions' folder
''=======================================================================
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const m_strDeletedPST As String = "C:\Outlook_Data\archivage.pst"
Private Const m_strDelDispName As String = "Archives"
Private Const m_iDays As Integer = 60

Sub MoveOldMail()
''=======================================================================
'' This routine is visible as a macro and is the heart of the move process
'' Calls: AttachPST, DetachPST, Quote
''=======================================================================

On Error GoTo Proc_Err

Dim blnSuccess As Boolean
Dim objNS As Outlook.NameSpace
Dim objAllItems As Outlook.Items
Dim objItemsToMove As Outlook.Items
Dim objItem As Object
Dim objTargetFolder As Outlook.MAPIFolder
Dim objPST As Outlook.MAPIFolder
Dim strSearch As String
Dim iCount As Integer
Dim i As Integer

''Attach pst file
blnSuccess = AttachPST(m_strDeletedPST, m_strDelDispName, objPST)

If Not blnSuccess Then
MsgBox "Could not attached '" & m_strDeletedPST & "', aborting
move."
GoTo Proc_Exit
End If

'' Wait a couple of seconds for everything to catch up
Sleep 3000

''We have the archive pst attached
Set objNS = Application.GetNamespace("MAPI")
Set objAllItems = objNS.GetDefaultFolder(olFolderDeletedItems).Items

''create filter based on date
strSearch = "[Reçu] <= " & Quote(FormatDateTime(Now - m_iDays,
vbShortDate) & " " & _
FormatDateTime(Now - m_iDays, vbShortTime))

''========== Move Deleted Items =============
''Get the 'Deletions' folder in the newly attached pst file
Set objTargetFolder = objPST.Folders.Item("éléments supprimés")

''Now restrict the email according to date
Set objItemsToMove = objAllItems.Restrict(strSearch)

''Get count of all items to be moved
iCount = objItemsToMove.Count

Debug.Print "Deleted Items: " & iCount

'' Loop from back to front of the restricted collection, moving each
file
For i = iCount To 1 Step -1
objItemsToMove.Item(i).Move objTargetFolder
Next


'' Now detach the added pst file
DetachPST m_strDelDispName

'' Wait a couple of seconds for everything to catch up
Sleep 3000


Proc_Exit:
''Clean up
If Not objAllItems Is Nothing Then Set objAllItems = Nothing
If Not objItem Is Nothing Then Set objItem = Nothing
If Not objItemsToMove Is Nothing Then Set objItemsToMove = Nothing
If Not objTargetFolder Is Nothing Then Set objTargetFolder = Nothing
If Not objNS Is Nothing Then Set objNS = Nothing

Exit Sub
Proc_Err:
MsgBox Err.Description, , "MoveOldMail"
GoTo Proc_Exit

End Sub

Private Function AttachPST(astrPSTName As String, astrDisplayName As String,
aobj As Outlook.MAPIFolder) As Boolean
''=======================================================================
'' This routine used the received information to attach an existing pst
'' file, returning a handle to the attached file
''=======================================================================
On Error GoTo Proc_Err
Dim objNS As Outlook.NameSpace


'Check if pst file exists, if exist then Add pst file...
If Len(Dir$(astrPSTName)) = 0 Then
MsgBox "Cannot connect to 'Deleted' pst file"
Exit Function
End If

Set objNS = Application.GetNamespace("MAPI")
objNS.AddStore astrPSTName
Set aobj = objNS.Folders.GetLast
'Change the Display Name from the new pst file ...
aobj.Name = astrDisplayName

'' Return success code
AttachPST = True

Proc_Exit:
''If Not objFolder Is Nothing Then Set objFolder = Nothing
If Not objNS Is Nothing Then Set objNS = Nothing
Exit Function
Proc_Err:
MsgBox Err.Description, , "AttachPST"
AttachPST = False
GoTo Proc_Exit
End Function


Function DetachPST(astrDisplayName As String) As Boolean
''=======================================================================
'' This routine used the received display name to close an existing pst
'' file
''=======================================================================
On Error GoTo Proc_Err
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(astrDisplayName)
objNS.RemoveStore objFolder

'' Return success code
DetachPST = True

Proc_Exit:
If Not objFolder Is Nothing Then Set objFolder = Nothing
If Not objNS Is Nothing Then Set objNS = Nothing
Exit Function

Proc_Err:
MsgBox Err.Description, , "DetachPST"
DetachPST = False
GoTo Proc_Exit

End Function

Private Function Quote(MyText)
''Used for properly quoting the filter string
Quote = Chr(34) & MyText & Chr(34)
End Function

je sais comment lui indiqué la boite de réception mais pas comment lui dire
de parcourir tout les sous-dossiers et de me recréer la meme arborescence
dans le pst d'archivage...

Si quelqu'un peut m'aider à completer ce code ce serait super..

Merci d'avance

seb