Sub triMessages_dansBoiteReception()
'nécéssite d'activer la référence Microsoft Outlook 10.0 Object Library
Dim olApp As New Outlook.Application
Dim olSpace As Outlook.nameSpace
Dim olFolder As Outlook.MAPIFolder, olInbox As Outlook.MAPIFolder
Dim Adresse As Outlook.addressList
Dim i As Integer, j As Integer
Dim leContact As Boolean
On Error goTo Fin
Set olSpace = olApp.getNamespace('MAPI'Â'Â')
Set olInbox = olSpace.getDefaultFolder(olFolderInbox)
Set olFolder = olInbox.Folders.Add('Nouveau Répertoire ' & Format(Date, 'yyyymmdd'Â'Â'))
Set Adresse = olSpace.addressLists('Contacts'Â'Â')
On Error goTo 0
'################################################################
''*!* normalement le nouveau dossier doit etre créé sans volet de prévisualisation
olApp.activeExplorer.currentView = 'Messages'
'################################################################
For j = olInbox.Items.Count To 1 Step -1
leContact = False
For i = 1 To Adresse.addressEntries.Count
If olInbox.Items.Item(j).senderName = Adresse.addressEntries.Item(i) Then _
leContact = True: Exit For
Next i
If leContact = False Then olInbox.Items.Item(j).Move olFolder
Next j
'msgBox olFolder.Items.Count & ' messages non identifiés ont été tranférés dans ' & _
'le dossier Outlook : Nouveau Répertoire ' & Format(Date, 'yyyymmdd'Â'Â'), , 'Message'
Exit Sub
Fin:
msgBox 'Opération annulée : le nouveau répertoire spécifié existe déja .', , 'Message'
End Sub