Vendredi 28 Juillet 2017  
Navigation
FAQ Outlook
» Foire Aux Questions «
Recherche
Téléchargements
Forums Outlook
Plan du site
Liens
Login

Les inscriptions sont fermées

Pseudo

Mot de passe

Se souvenir de moi



Mot de passe oublié ? Mot de passe oublié ?
Connexions
Bienvenue à [FAMACLUB]
le 1,414ème membre
Visiteurs en ligne : 3
Membres en ligne : 0

 EMERGENCY 2 jours
 callaghi 1 semaine
 JièL 4 semaines
 zorro71 8 semaines
 Alphator 26 semaines
 ande 32 semaines
 Oliv 34 semaines
 cubitus 38 semaines
 angel 48 semaines
 Quartzkyte 57 semaines

Non activés :0

Nombre de visiteurs
depuis le : 12/11/2008

Aujourd'hui:669
En ligne :3
Max. en ligne:312
Max. / jour:66 529
Total hier:5 053
Total ce mois:149 179
Total visites:17 972 800
Moyenne/jour:5 654

Dernières 24h

























Publicité ; elle permet de financer le site
Navigation parmi les catégories/articles
« Catégorie     Q15000 Macros - VBA (41)  Catégorie »
[<<]  « Article  Article »  [>>]
R15920 [VBA] Archivage
Voici une macro de GEO pour pallier au manque d'efficacité de l'archivage automatique.

"Une macro d'archivage des éléments les plus courants : courriers émis et reçus, Rendez-vous et tâches.

Au départ j'avais mis deux paramètres séparés pour distinguer les courriers émis des reçus. Je pense qu'il faudrait le remettre, mais ça me posait problème pour la deuxième macro.

La deuxième macro balaie tous les dossiers et sous-dossiers (jusqu'à 3

niveaux) en vue d'archivage."

Code :
Option Explicit
 
' Constantes de paramétrage à définir impérativement
Const Test As Boolean = True ' true = ne fait pas le transfert
 
Const DélaiCourrier As Integer = 365 * 3 ' en jours
Const ArchiverCourrier As Boolean = False
 
Const DélaiTache As Integer = 30 ' tache finie depuis
Const ArchiverTache As Boolean = False
 
Const DélaiNote As Integer = 365 * 3 ' note écrite il y a plus de ...
Const ArchiverNote As Boolean = False
 
Const DélaiAgenda As Integer = 365 ' rdv fini depuis
Const ArchiverAgenda As Boolean = True
 
 
Private Sub ArchiverCourriersAgenda()
' Ne traite que les courrier envoyés ou reçus, les rendez-vous et les tâches.
' On suppose que l'archivage doit se faire dans le dernier
' dossier dont le nom contient 'archivage'.
' L'utilisateur doit donc créer un nouveau dosssier
' lorsqu'il estime que le précédent est suffisamment plein.
' Exemple :
'   Dossier Archivage n 1
'   Dossier Archivage n 2
'   ...
 
Dim Dossiers As Folders
Dim Dossier As Folder
Dim DossierDestArchivage As Folder
Dim NomDossierArchivage As String
Dim NS As NameSpace
Dim DateLimite As Date
Dim Element As Object
Dim Courrier As MailItem
Dim Tache As TaskItem
Dim RendezVous As AppointmentItem
Dim i As Long
Dim NbRecept As Long
Dim NbEnvoi As Long
Dim NbTache As Long
Dim NbRendezVous As Long
 
Dim HeureDébut As Date
Dim HeureFin As Date
Dim Durée As String
Dim Message As String
 
HeureDébut = Now()
Set NS = Application.GetNamespace("MAPI")
Set Dossiers = NS.Folders
NomDossierArchivage = ""
For Each Dossier In Dossiers ' niveau principal
  If InStr(1, UCase(Dossier.Name), "ARCHIVAGE") > 0 Then ' c'est un dossier d'archivage
    NomDossierArchivage = Dossier.Name
  End If
Next
' Le nom du dernier dossier d'archivage
If NomDossierArchivage = "" Then
  MsgBox "Définissez un dossier d'archivage" & vbCrLf & "Abandon", vbCritical
  End
End If
 
If ArchiverCourrier Then  ' Réception
  DateLimite = Date - DélaiCourrier
  NbRecept = 0
  Set Dossier = NS.GetDefaultFolder(olFolderInbox) ' boite de réception
  Set DossierDestArchivage = NS.Folders(NomDossierArchivage).Folders(Dossier.Name)
  For i = Dossier.Items.count To 1 Step -1
    Set Element = Dossier.Items(i)
   
    Select Case TypeName(Element)
    Case "MailItem"
      Set Courrier = Element
      If Courrier.ReceivedTime < DateLimite Then
        ' A archiver
        'Debug.Print Courrier.Subject
        NbRecept = NbRecept + 1
        If Not Test Then Courrier.Move DossierDestArchivage
      End If
    Case "ReportItem"
      If Element.CreationTime < DateLimite Then
        ' A archiver
        NbRecept = NbRecept + 1
        If Not Test Then Element.Move DossierDestArchivage
      End If
    Case Else
      Debug.Print TypeName(Element)
    End Select
    DoEvents
  Next
  Debug.Print "Boite de réception : " & NbRecept & " / " & Dossier.Items.count
 
End If
 
If ArchiverCourrier Then  ' courriers envoyés
  DateLimite = Date - DélaiCourrier
  NbEnvoi = 0
  Set Dossier = NS.GetDefaultFolder(olFolderSentMail) ' boite des messages envoyés
  Set DossierDestArchivage = NS.Folders(NomDossierArchivage).Folders(Dossier.Name)
  For i = Dossier.Items.count To 1 Step -1
    Set Element = Dossier.Items(i)
   
    If TypeName(Element) = "MailItem" Then
      Set Courrier = Element
      If Courrier.ReceivedTime < DateLimite Then
        ' A archiver
        'Debug.Print Courrier.Subject
        NbEnvoi = NbEnvoi + 1
        If Not Test Then Courrier.Move DossierDestArchivage
      End If
    End If
    DoEvents
  Next
  Debug.Print "NbEnvoi : " & NbEnvoi & " / " & Dossier.Items.count
 
End If
 
 
If ArchiverTache Then
  DateLimite = Date - DélaiTache
  NbTache = 0
  Set Dossier = NS.GetDefaultFolder(olFolderTasks) ' Tâches
  Set DossierDestArchivage = NS.Folders(NomDossierArchivage).Folders(Dossier.Name)
  For i = Dossier.Items.count To 1 Step -1
    Set Element = Dossier.Items(i)
   
    If TypeName(Element) = "TaskItem" Then
      Set Tache = Element
      If Tache.DateCompleted < DateLimite Then
        ' A archiver
        'Debug.Print Courrier.Subject
        NbTache = NbTache + 1
        If Not Test Then Tache.Move DossierDestArchivage
      End If
    End If
    DoEvents
  Next
  Debug.Print "NbTache : " & NbTache & " / " & Dossier.Items.count
 
End If
 
If ArchiverAgenda Then
  DateLimite = Date - DélaiAgenda
  NbRendezVous = 0
  Set Dossier = NS.GetDefaultFolder(olFolderTasks) ' Tâches
  Set DossierDestArchivage = NS.Folders(NomDossierArchivage).Folders(Dossier.Name)
  For i = Dossier.Items.count To 1 Step -1
    Set Element = Dossier.Items(i)
   
    If TypeName(Element) = "AppointmentItem" Then
      Set RendezVous = Element
      If RendezVous.DateCompleted < DateLimite Then
        ' A archiver
        'Debug.Print Courrier.Subject
        NbRendezVous = NbRendezVous + 1
        If Not Test Then Tache.Move DossierDestArchivage
      End If
    Else
      'Debug.Print "Calendrier", TypeName(Element)
    End If
    DoEvents
  Next
 
  Debug.Print "NbRendezVous : " & NbRendezVous & " / " & Dossier.Items.count
 
End If
 
Set NS = Nothing
Set Dossiers = Nothing
DoEvents
HeureFin = Now()
Durée = Format((HeureFin - HeureDébut) * 24 * 60, "#0.0")
 
If Test Then
  Message = "Simulation " & vbCr & "Auraient été déplacés :" & vbCr
Else
  Message = "Archivage " & vbCr & "Ont été déplacés :" & vbCr
End If
Message = Message & "Reçus            : " & NbRecept & vbCr
Message = Message & "Envoyés        : " & NbEnvoi & vbCr
Message = Message & "Tâches           : " & NbTache & vbCr
Message = Message & "Rendez-vous : " & NbRendezVous & vbCr & vbCr
 
Message = Message & "Durée du traitement :  " & Durée & " minutes" & vbCr
MsgBox Message
 
 
End Sub
 
Private Sub ArchivageComplet()
' Traite tous les dossiers des 'Dossiers personnels'.
' le seul filtre est sur le type d'éléments : MailItem, TaskItem
' On suppose que l'archivage doit se faire dans le dernier
' dossier dont le nom contient 'archivage'.
' L'utilisateur doit donc cérer un nouveau dosssier
' lorsqu'il estime que le précédent est plein.
' Exemple :
'   Dossier Archivage n 1
'   Dossier Archivage n 2
 
Dim Dossiers As Folders
Dim ListeDossiers() As Folder
Dim Dossier As Folder
Dim SousDossier1 As Folder
Dim SousDossier2 As Folder
Dim DossierDestArchivage As Folder
Dim NomDossierArchivage As String
Dim NomDossierActif As String
Dim NS As NameSpace
Dim DateLimiteCourrier As Date
Dim DateLimiteTache As Date
Dim DateLimiteRendezVous As Date
Dim DateLimiteNote As Date
Dim Element As Object
Dim Courrier As MailItem
Dim Tache As TaskItem
Dim RendezVous As AppointmentItem
Dim Note As NoteItem
Dim i As Long
Dim j As Integer
Dim k As Integer
Dim indice As Integer
Dim NbCourrierTot As Long
Dim NbTacheTot As Long
Dim NbRendezVousTot As Long
Dim NbNoteTot As Long
Dim NbCourrierAEffacer As Long
Dim NbTacheAEffacer As Long
Dim NbRendezVousAEffacer As Long
Dim NbNoteAEffacer As Long
Dim NbDossiers As Integer
Dim HeureDébut As Date
Dim HeureFin As Date
Dim Durée As String
Dim Message As String
Dim DossiersNonTraités() As Variant
 
HeureDébut = Now()
Set NS = Application.GetNamespace("MAPI")
Set Dossiers = NS.Folders
NomDossierActif = NS.GetDefaultFolder(olFolderInbox).Parent
NomDossierArchivage = ""
For Each Dossier In Dossiers ' niveau principal
  If InStr(1, UCase(Dossier.Name), "ARCHIVAGE") > 0 Then ' c'est un dossier d'archivage
    NomDossierArchivage = Dossier.Name
  End If
Next
' Le nom du dernier dossier d'archivage
If NomDossierArchivage = "" Then
  MsgBox "Définissez un dossier d'archivage " & vbCrLf & "Abandon", vbCritical
  End
End If
' ======= Les dossiers à ne pas traiter
'  LISTE A MODIFIER EVENTUELLEMENT
 
  ' Dossier des Problèmes de synchronisation (Exchange)
  ReDim DossiersNonTraités(0)
  DossiersNonTraités(0) = Empty
  ' Sans exchange, le GetDefaultFolder produit une erreur
  On Error Resume Next
  Set DossiersNonTraités(UBound(DossiersNonTraités)) = NS.GetDefaultFolder(olFolderSyncIssues)
  If Not IsEmpty(DossiersNonTraités(UBound(DossiersNonTraités))) Then
    ReDim Preserve DossiersNonTraités(UBound(DossiersNonTraités) + 1)
    Set DossiersNonTraités(UBound(DossiersNonTraités) + 1) = Empty
  End If
  ' Dossier des conflits (normalement sous-dossier dans le précédent)
  Set DossiersNonTraités(UBound(DossiersNonTraités)) = NS.GetDefaultFolder(olFolderConflicts)
  If Not IsEmpty(DossiersNonTraités(UBound(DossiersNonTraités))) Then
    ReDim Preserve DossiersNonTraités(UBound(DossiersNonTraités) + 1)
    Set DossiersNonTraités(UBound(DossiersNonTraités) + 1) = Empty
  End If
  ' Dossier des pannes locales (même remarque)
  Set DossiersNonTraités(UBound(DossiersNonTraités)) = NS.GetDefaultFolder(olFolderLocalFailures)
  If Not IsEmpty(DossiersNonTraités(UBound(DossiersNonTraités))) Then
    ReDim Preserve DossiersNonTraités(UBound(DossiersNonTraités) + 1)
    Set DossiersNonTraités(UBound(DossiersNonTraités) + 1) = Empty
  End If
  ' Dossier des pannes de serveur (même remarque)
  Set DossiersNonTraités(UBound(DossiersNonTraités)) = NS.GetDefaultFolder(olFolderServerFailures)
  If Not IsEmpty(DossiersNonTraités(UBound(DossiersNonTraités))) Then
    ReDim Preserve DossiersNonTraités(UBound(DossiersNonTraités) + 1)
    Set DossiersNonTraités(UBound(DossiersNonTraités) + 1) = Empty
  End If
  ' Dossier des contacts
  Set DossiersNonTraités(UBound(DossiersNonTraités)) = NS.GetDefaultFolder(olFolderContacts)
  If Not IsEmpty(DossiersNonTraités(UBound(DossiersNonTraités))) Then
    ReDim Preserve DossiersNonTraités(UBound(DossiersNonTraités) + 1)
    Set DossiersNonTraités(UBound(DossiersNonTraités) + 1) = Empty
  End If
  ' Eléméments supprimés
  Set DossiersNonTraités(UBound(DossiersNonTraités)) = NS.GetDefaultFolder(olFolderDeletedItems)
  If Not IsEmpty(DossiersNonTraités(UBound(DossiersNonTraités))) Then
    ReDim Preserve DossiersNonTraités(UBound(DossiersNonTraités) + 1)
    Set DossiersNonTraités(UBound(DossiersNonTraités) + 1) = Empty
  End If
  ' Dossier des pourriels
  Set DossiersNonTraités(UBound(DossiersNonTraités)) = NS.GetDefaultFolder(olFolderJunk)
  If Not IsEmpty(DossiersNonTraités(UBound(DossiersNonTraités))) Then
    ReDim Preserve DossiersNonTraités(UBound(DossiersNonTraités) + 1)
    Set DossiersNonTraités(UBound(DossiersNonTraités) + 1) = Empty
  End If
  ' Dossier des brouillons
  Set DossiersNonTraités(UBound(DossiersNonTraités)) = NS.GetDefaultFolder(olFolderDrafts)
 
  If IsEmpty(DossiersNonTraités(UBound(DossiersNonTraités))) And _
    UBound(DossiersNonTraités) > 0 Then
    ReDim Preserve DossiersNonTraités(UBound(DossiersNonTraités) - 1)
  End If
 
  ' Traités  (par déduction):
  'olFolderCalendar  Le dossier Calendrier.
  'olFolderContacts  Le dossier Contacts.
  'olFolderInbox     Le dossier Boîte de réception.
  'olFolderJournal   Le dossier Journal.
  'olFolderManagedEmail Le dossier de niveau supérieur dans le groupe Dossiers gérés.  Exchange.
  'olFolderNotes     Le dossier Notes.
  'olFolderOutbox    Le dossier Boîte d'envoi.
  'olFolderSentMail  Le dossier Éléments envoyés.
  'olFolderTasks     Le dossier Tâches.
  'olFolderToDo      Le dossier À faire.
  'olPublicFoldersAllPublicFolders Le dossier Tous les dossiers publics dans le magasin Dossiers publics Exchange.
  'olFolderRssFeeds  Le dossier Flux RSS.
 
  On Error GoTo 0
 
' ================  Mémoriser les dossiers actifs
ReDim ListeDossiers(0)
Set ListeDossiers(0) = NS.Folders(NomDossierActif)
For i = 1 To NS.Folders(NomDossierActif).Folders.count
  Set Dossier = NS.Folders(NomDossierActif).Folders(i)
  ' Dossier traité ?
  If Not IsEmpty(DossiersNonTraités(0)) Then
  ' la liste des dossiers non traités en non vide
    For k = 0 To UBound(DossiersNonTraités)
      If Dossier = DossiersNonTraités(k) Then GoTo DossierSuivant
    Next k
  End If
  ' ==========  Ajouter éventuellment des dossiers à ne pas traiter
  ' exemple
  ' If Dossier.Name = "Temporaire" Then GoTo DossierSuivant
 
  indice = UBound(ListeDossiers) + 1
  ReDim Preserve ListeDossiers(indice)
  Set ListeDossiers(indice) = Dossier
  Debug.Print "Dossier : " & ListeDossiers(indice).Name
  'Contient des sous-dossiers ?
  If Dossier.Folders.count > 0 Then
    ' structure traitée : 'Dossiers personnels'
    '                        1-Dossier
    '                           1.1-Sous-dossier 1
    '                                1.1.1 Sous-Dossier2
    '                           1.2-Sous-dossier 1
    '                                1.2.1 Sous-Dossier2
    '                                1.2.2 Sous-Dossier2
    '                        2-Dossier
    '   etc.
   
    For Each SousDossier1 In Dossier.Folders
      indice = UBound(ListeDossiers) + 1
      ReDim Preserve ListeDossiers(indice)
      Set ListeDossiers(indice) = SousDossier1
      Debug.Print "Sous-Dossier 1 : " & ListeDossiers(indice).Name
      ' ======================
      ' ajouter ici le code pour niveaux supplémentaires
      For Each SousDossier2 In SousDossier1.Folders
        indice = UBound(ListeDossiers) + 1
        ReDim Preserve ListeDossiers(indice)
        Set ListeDossiers(indice) = SousDossier2
        Debug.Print "Sous-Dossier 2 : " & ListeDossiers(indice).Name
        ' ======================
      ' ajouter ici le code pour niveaux supplémentaires
     
     
     
    Next
     
     
    Next
  End If
DossierSuivant:
 
Next i
 
 
NbDossiers = UBound(ListeDossiers)
DateLimiteCourrier = Date - DélaiCourrier
DateLimiteTache = Date - DélaiTache
DateLimiteRendezVous = Date - DélaiAgenda
DateLimiteNote = Date - DélaiNote
NbCourrierTot = 0
NbTacheTot = 0
NbRendezVousTot = 0
NbCourrierAEffacer = 0
NbTacheAEffacer = 0
NbRendezVousAEffacer = 0
NbNoteAEffacer = 0
 
' Boucle de balayage de tous les dossiers de "Dossiers Personnels"
For j = 1 To NbDossiers
  Set Dossier = ListeDossiers(j)
  On Error GoTo Sauter  ' pour les dossiers sans correspondance en archives
 
  Set DossierDestArchivage = NS.Folders(NomDossierArchivage).Folders(Dossier.Name)
  ' balayage de tous les éléments
  On Error GoTo 0
  For i = Dossier.Items.count To 1 Step -1
    Set Element = Dossier.Items(i)
    Select Case TypeName(Element)
    Case "MailItem" ' tout courrier où qu'il soit : émis, reçu, supprimé, brouillon, ...
      Set Courrier = Element
      NbCourrierTot = NbCourrierTot + 1
      If Courrier.ReceivedTime < DateLimiteCourrier Then
        NbCourrierAEffacer = NbCourrierAEffacer + 1
        If Not Test Then Courrier.Move DossierDestArchivage
      End If
     
    Case "ReportItem"  ' message particulier indiquant la non remise
      NbCourrierTot = NbCourrierTot + 1
      If Element.CreationTime < DateLimiteCourrier Then
        ' A archiver
        NbCourrierAEffacer = NbCourrierAEffacer + 1
        If Not Test Then Element.Move DossierDestArchivage
      End If
     
    Case "AppointmentItem" ' les rendez-vous
      NbRendezVousTot = NbRendezVousTot + 1
      Set RendezVous = Element
      If RendezVous.End < DateLimiteRendezVous Then
        ' A archiver
        NbRendezVousAEffacer = NbRendezVousAEffacer + 1
        If Not Test Then Element.Move DossierDestArchivage
      End If
     
    Case "TaskItem" ' les tâches (dans le calendrier)
      NbTacheTot = NbTacheTot + 1
      Set Tache = Element
      If Tache.DateCompleted < DateLimiteTache Then
        ' A archiver
        NbTacheAEffacer = NbTacheAEffacer + 1
        If Not Test Then Element.Move DossierDestArchivage
      End If
   
    Case "ContactItem" ' les contacts
      ' on ne fait rien
    Case "DistListItem" ' les listes de diffusion
      ' on ne fait rien
     
    Case "NoteItem" ' les Notes (dans le calendrier)
      NbNoteTot = NbNoteTot + 1
      Set Note = Element
      If Note.LastModificationTime < DateLimiteNote Then
        ' A archiver
        NbNoteAEffacer = NbNoteAEffacer + 1
        If Not Test Then Element.Move DossierDestArchivage
      End If
     
   
    Case Else
      Debug.Print TypeName(Element)
    End Select
  Next i
 
 
  GoTo Boucle
Sauter:
  Resume Boucle
 
Boucle:
DoEvents
Next j
Debug.Print "NbCourrier : " & NbCourrierAEffacer & " / " & NbCourrierTot
Debug.Print "NbTaches : " & NbTacheAEffacer & " / " & NbTacheTot
Debug.Print "NbRendez-vous : " & NbRendezVousAEffacer & " / " & NbRendezVousTot
Debug.Print "NbNotes : " & NbNoteAEffacer & " / " & NbNoteTot
 
Set NS = Nothing
Set Dossiers = Nothing
DoEvents
HeureFin = Now()
Durée = Format((HeureFin - HeureDébut) * 24 * 60, "#0.0")
If Test Then
  Message = "Simulation " & vbCr & "Auraient été déplacés :" & vbCr
Else
  Message = "Archivage " & vbCr & "Ont été déplacés :" & vbCr
End If
Message = Message & "Courriers       : " & NbCourrierAEffacer & " / " & NbCourrierTot & vbCr
Message = Message & "Notes             : " & NbNoteAEffacer & " / " & NbNoteTot & vbCr
Message = Message & "Tâches           : " & NbTacheAEffacer & " / " & NbTacheTot & vbCr
Message = Message & "Rendez-vous : " & NbRendezVousAEffacer & " / " & NbRendezVousTot & vbCr & vbCr
 
Message = Message & "Durée du traitement :  " & Durée & " minutes" & vbCr
MsgBox Message
 
End Sub

Publié par Oliv le lundi 11 février 2008 10:06 0 Commentaires 11024 Lecture(s) Imprimer
Commentaires
les commentaires sont fermés.
Copyright et partage
Ce site est sous licence Creative Commons.
Vous pouvez utiliser toutes les informations présentent ici, mais il vous est interdit de les reproduire sans citer la source.

Creative Commons License
OUI au partage
NON au « copillage »

Ajouter aux favoris / partager : 
URL :
BBcode :
HTML :
Cliquez ci dessus sur le lien que vous voulez copier et [Ctrl] + [C] ou cliquez sur le bouton [ C ]
Articles similaires
Articles Catégories
R06032 Utiliser l'archivage automatique avec les dates de réception Q06000 Les fichiers d'Outlook
R15045 [VBA] Ouvrir l'arborescence des pst contenant une boîte de réception Q15000 Macros - VBA
R15930 [VBA] Création de menu dans outlook Q15000 Macros - VBA
R15380 [VBA] Envoi via VBA : suppression de la confirmation d'envoi Q15000 Macros - VBA
R15280 [VBA] Exporter un mail et l'ouvrir dans IE avec ses images Q15000 Macros - VBA
Nuage de tags
R11050 Restaurer ses paramètres de compte de messagerie, R15200 [VBA] Enregistrer en .msg, R15430 [VBA] Cocher plusieurs calendriers à l'ouverture, R05010 Ne pas imprimer la liste des (nombreux) destinataires d'un message, R15900 [VBA] Relever des boites pop sequentiellement (FREE), R10060 Sauvegarder le carnet d'adresses personnel (.PAB), R12020 Naviguer dans le calendrier, R08240 Pourquoi la désinstallation/Réinstallation ne fait rien ?!, R01040 Laisser une copie de message sur le serveur, R07100 Exporter / Importer une liste d'expéditeurs indésirables, R03060 Créer un papier à lettres a partir d'un message reçu, R11070 Restaurer les fichiers de paramètres d'Outlook, R13030 Créer une tâche, R00130 Fonctionnalités abandonnées et/ou modifiées dans Outlook 2007, R08220 Liens hypertexte inactifs

aucun Crack, CrackZ, no-CD, DownloadZ, TelechargementZ, Serial, Numéro de série, N0 de série, Serialz ni Keygen pour Outlook sur ce site.

Blague aléatoire
Publicité
Météo Marseille
[/\] Copyright JièL / Jean-Louis Goubert © 2003-2009 [/\]