1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
| Sub moveToArchive()
'Bligoo - March 2008
'http://bligoo.wordpress.com/
On Error Resume Next
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objNS.Folders("Dossiers personnels")
If Application.ActiveExplorer.Selection.Count = 0 Then
'[asy]Contrôle qu'au moins un message est sélectionné, sinon fin de la macro
Exit Sub
End If
If objFolder Is Nothing Then
'[asy]Controler que le dossier de destination est valide
MsgBox "Le dossier cible n'existe pas!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.UnRead = False '[asy]Le mail passe dans le statut lu
objItem.Move objFolder '[asy]Le mail est déplacé dans le répertoire cible
objItem.Categories = "Projet - Altéa"
End If
End If
Next
Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub |
Partager