Public WithEvents AM As MailItem
 
'Lancement lors de la modification des propriétés d'un mail.
'"Name" est un string et correspond au nom de la propriété.
 
Private Sub AM_PropertyChange(ByVal Name As String)
 
    'Je définis les variables.
    Dim CategorieName As String
 
    Select Case Name
        Case "Categories" 'Si "Name" contient "Categories", je traite le mail. Sinon je laisse tomber.
            If AM.Categories <> "" Then 'Si je donne une catégorie au mail je continue le traitement.
                CategorieName = AM.Categories
                AM.Categories = CategorieName
                MoveItems (CategorieName)
            End If
    End Select
End Sub
 
'Lancement lors de la sélection d'un objet.
'"Item" est un objet et correspond au type d'objet sélectionné.
 
Private Sub Application_ItemLoad(ByVal Item As Object)
    If Item.Class = olMail Then 'Si "Item" est un mail, je récupère le mail dans la variable AM. Sinon je laisse tomber.
        Set AM = Item
    Else
        Exit Sub
    End If
End Sub
 
Private Sub MoveItems(CategorieName)
 
    'Je définis les variables.
    Dim myOlapp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim myDestFolder As Outlook.Folder
 
    On Error GoTo MsgErr
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myDestFolder = myFolder.Folders(CategorieName) 'Je définis le répertoire de destination.
    AM.Move myDestFolder 'Je déplace le mail
 
    Set myOlapp = Nothing
    Set myNameSpace = Nothing
    Set myFolder = Nothing
    Set myDestFolder = Nothing
 
MsgErr:
    If Err.Number = -2147221233 Then
        MsgBox "Le dossier de destination n'existe pas !", vbCritical, "Erreur !"
    Else
        MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    End If
 
    Set myOlapp = Nothing
    Set myNameSpace = Nothing
    Set myFolder = Nothing
    Set myDestFolder = Nothing
 
    Exit Sub
 
End Sub