R15450 [VBA] Supprimer automatiquement les éléments de + de x jours dans un dossier.
Publié par Oliv le Mercredi 16 avril 2008 11:36
A placer dans ThisOutlookSession

 Private Sub Application_startup()
'---------------------------------------------------------------------------------------
' Procedure : Application_startup
' Author    : GEO et Oliv'
' Date      : 16/04/2008
' Purpose   : Supprimes les éléments de + de 30 jours dans le dossier désigné.
'---------------------------------------------------------------------------------------
'
Dim Dossier 'est le dossier dans lequel opérer
Dim Ns As NameSpace
Dim Nb As Integer
Dim i As Integer
Set Ns = GetNamespace("MAPI")
 
'Set Dossier = Ns.Folders("Dossiers personnels").Folders("Éléments supprimés ")
Set Dossier = Ns.GetDefaultFolder(olFolderDeletedItems)
'Les constantes OlDefaultFolders possibles sont :
'olFolderCalendar
'olFolderContacts
'olFolderDeletedItems
'olFolderDrafts
'olFolderInbox
'olFolderJournal
'olFolderNotes
'olFolderOutbox
'olFolderSentMail
'olFolderTasks
'olPublicFoldersAllPublicFolders
'olFolderJunk
 
 
Dim DateStart As Date
Dim DateToCheck As String
 
DateStart = DateAdd("d", -30, Date)
DateToCheck = "[CreationTime] <= """ & DateStart & """"
Set myRestrictItems = Dossier.Items.Restrict(DateToCheck)
Nb = myRestrictItems.Count
For i = Nb To 1 Step -1
      myRestrictItems(i).Delete
 
Next i
End Sub