Code pour archiver

[sebinator]

Bonjour,

L'archivage ne fonctionne pas. Je pense que je suis concerné par l'article suivant :

Bien que vous mettiez une date d'archivage proche, les mails ne sont pas déplacés dans le dossier d'archivage
--------------------------------------------------------------------------------

C'est un problème connu et sans solution, dixit MS. La date qui est utilisée pour l'archivage n'est pas la date d'envoi ni de réception du message, mais la date d'arrivée DANS le dossier !!!

Un exemple pour mieux comprendre : aujourd'hui vous réimportez des anciens messages ou encore vous placez des messages dans un dossier, ce dernier étant destiné à l'archivage. La date qui sera utilisée pour l'archivage est donc la date du jour ; et si vous avez paramétré l'archivage des messages "plus anciens que : 6 mois", c'est 6 mois à compter de cette date.

Quand MS ne veut pas modifier qqchose ils disent "It's Feature" ou alors "By Design" (c'est précisément la réponse que j'ai eue directement de la part de MS Corp. quand j'étais MVP), et vous pouvez toujours courir pour archiver automatiquement vos mails en fonction de la date visible de ceux ci.

Je cherche donc à me faire un bouton de commande pour archiver mes mails de plus de 6 mois.

Où je peux trouver un exemple de code que je pourrais adapter à mes besoins ?

Merci

Seb

[sebinator]

J'ai trouvé ce code et j'essaye de l'adapter mais il me fait une erreur sur next

Option Explicit
Public Sub Archivage_a_180_jours()
'---------------------------------------------------------------------------------------
' Procédure : EssaisCode
' Auteur    : Dolphy35
' Site      : http://dolphy35.developpez.com
' Détail    : Initiallement Permet de lister les noms d'expéditeur des Mails présent dans la boîte de réception.
'
' Modif : parcours la boite de réception et deplace tous les de plus de 180'jours
'---------------------------------------------------------------------------------------
'
    'Déclarations
    'On Error Resume Next
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim mapDossier As Outlook.MAPIFolder
    Dim mapdossierDest As Outlook.MAPIFolder
    Dim Datearchives As Date
    
    'Instancies
    Set olApp = Outlook.Application
    Set mapDossier = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set mapdossierDest = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Archivages")
    Datearchives = Date - 180
    
    'Boucle parcourant les Emails de la boîte de réception
    For Each olMail In mapDossier.Items
        If olMail.ReceivedTime <= Datearchives Then
        olMail.Move mapdossierDest
        End If
        Next '<---------ERREUR   
   
End Sub

Pourquoi cela ne fonctionne pas ?

[Dolphy35]

Salut Seb

Ton code ne fonctionne pas lorsque la boucle tombe sur un accusé de réception par exemple (err 13).

Dans ce post Oliv- et moi parlons de contrôler si l'item est bien un Mail
exemple :

If Item.Class = olMail Then
...
End If

le soucis est que dans ta boucle For si tu sors, tu ne test plus les mails suivants

une autre méthode existe en utilisant la méthode AdvancedSearch, exemple dans le tuto : AdvancedSearchComplete et AdvancedSearchStopped

Ci-joint le code à placer dans ThisOutlookSession, j'ai repris l'exemple du tuto en modifiant pour ton cas :

Public blnStopSearch As Boolean
 
Sub Recherche()
'---------------------------------------------------------------------------------------
' Procédure : Recherche
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 21/04/2008
' Détail    : Effectue une recherche par la méthode AdvancedSearch
' Modifs    : 07/08/2008
' Quoi      : Recherche de Mails antérieurs de 180 jours de la date du jour.
'             de ceux-ci vers un dossier spécifique
'---------------------------------------------------------------------------------------
'
'Déclaration de l'objet et de la variable
    Dim ObjSearch As Outlook.Search
    Dim i As Integer
    Dim strFiltre As String
 
    'Initialisation du boolean
    blnStopSearch = False
 
    'Chargement des constante et variable, pour le filtre et le dossier de recherche
    strFiltre = "urn:schemas:httpmail:datereceived < '" & Date - 180 & "'"
    Const strDossier As String = "Inbox"
    
    'Instancie l'objet à la méthode AdvancedSearch
    Set ObjSearch = Application.AdvancedSearch(strDossier, strFiltre)
 
    'Boucle tant que AdvancedSearch n'a pas fini sa recherche, déclenche l'événement AdvancedSearchComplete
    While blnStopSearch = False
        DoEvents
    Wend
 
End Sub
 
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
'---------------------------------------------------------------------------------------
' Procédure : Application_AdvancedSearchComplete
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 21/04/2008
' Détail    : utilise l'événement AdvancedSearchComplete suite à une recherche
' Modifs    : 07/08/2008
' Quoi      : Recherche de Mails antérieurs de 180 jours de la date du jour et deplacement
'             de ceux-ci vers un dossier spécifique
'---------------------------------------------------------------------------------------
'
'Déclaration de l'objet
    Dim objResultat As Outlook.Results
    Dim olApp As Outlook.Application
    Dim mapdossierDest As Outlook.MAPIFolder
    
    'Instances
    Set olApp = Outlook.Application
    Set mapdossierDest = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Archivages")
    
    'Instancie à l'objet le résultat de la recherche
    Set objResultat = SearchObject.Results
    
    If objResultat.Count > 0 Then
        'Boucle en fonction du nombre d'occurrences trouvées
        For i = 1 To objResultat.Count
            objResultat.Item(i).Move mapdossierDest
        Next
    Else
        MsgBox "La recherche n'a trouvé aucune occurrence"
    End If
    'Passage à True de la Variable pour stopper la boucle
    blnStopSearch = True
 
End Sub

En espérant que cela te va ?

Dolphy

[sebinator]

Merci pour ta réponse

J'ai testé le code et cela ne fonctionne pas correctement, il devrait me déplacer au moins 200 mails et il déplace une acceptation de RV et rien d'autre.

[Dolphy35]

Salut,

Ce code fonctionne nickel chez moi : OL 2007.

Sous quel format sont tes mails ?

Dolphy

[sebinator]

Je suis sous outlook 2003..

format des mails ? j'ai de tout, html, texte brut..

[Dolphy35]

Salut,

Envoyé par sebinator

format des mails ?

Je pensais à quelque chose mais je viens de tester, ce n'est pas ça.

Je viens également de tester sur un version 2003 avec des mails + acceptation réunion, etc. Tout fonctionne à merveille.

La recherche s'effectue sur le date de réception.

Tu as collé le code que j'ai mis plus haut ?


Dolphy

[sebinator]

Merci pour ton aide dolphy,

Bien le code fonctionne mais le temps d'éxécution est très très très long... Il faudrait un progressbar pour avoir une indication de l'éxécution..


Comme j'ai des dossiers dans la boite de réception, j'ai ajouté l'option

SearchSubFolders:=True

reste plus qu'a recréer les sous-dossiers dans le dossier archivage et ca devrait étre bon.

Comment fait on pour indiquer un autre PST comme destination ?

seb

[sebinator]

j'ai trouvé un autre 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.

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

[sebinator]

pas d'idées...