VBA Outlook - Trie de message des reception

[microd]

Bonjour le Forum,

En me promenant sur la page personnel de Michel.Xld qui est d'ailleurs très bien faite ( ...merci à toi Michel ..). J'ai trouvé un code me permettant de créer des dossiers depuis Excel dans ma boîte personnel.
Ces dossiers ont toujours la même composition du type :
"Nombre" &"Dénomination"
Par ailleurs un autre code ( mais cette fois-ci dans Outlook) permets dès réception d'un mail de transférer automatiquement le message dans un des dossiers existant si l'objet du message correspond au nom d'un dossier .... et ça marche bien évidemment ..
Je souhaiterais modifier cette derniere condition par : si dans l'objet du message
une partie correspond au dossier alors transférer le message ..

Voila le code de départ non modifié ....Private Sub Application_NewMail()
triMessages_dansBoiteReception_V02
End Sub

cela va permettre de lancer automatiquement la procedure dès la reception d'un nouveau mesage




dans un module de l'editeur de macros Outlook :

Sub triMessages_dansBoiteReception_V02()
Dim olSpace As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder, olInbox As Outlook.MAPIFolder
Dim j As Integer

Set olSpace = Application.GetNamespace('MAPI')
Set olInbox = olSpace.GetDefaultFolder(olFolderInbox)

'boucle sur tous les messages de la boite de réception
For j = olInbox.Items.Count To 1 Step -1

On Error Resume Next
Set olFolder = olInbox.Folders(olInbox.Items(j).Subject)
On Error GoTo 0

If Not olFolder Is Nothing Then
'si le dossier existe (meme nom que le sujet du message):transfert du message
olInbox.Items(j).Move olFolder
Else
'si le dossier n'existe pas , creation puis transfert
Set olFolder = olInbox.Folders.Add(olInbox.Items(j).Subject)
Application.ActiveExplorer.CurrentView = 'Messages'
olInbox.Items(j).Move olFolder
End If

Set olFolder = Nothing
Next j

End Sub

Merci pour votre aide ...

 

[microd]

Re : VBA Outlook - Trie de message des reception

Bonjour le forum,

Vu le temps que j'ai passé à trouver une solution, je me permets de la faire partager, voici donc une procédure qui permets a partir des dossiers existants dans la boite de reception de créer des règles propres à chaque dossier
le nom de mes dossiers sont du type aaaa bbbb cccc donc pour chaque dossier si dans l'objet se trouve aaaa ou bbbb ou cccc le message est transférer dans le dossier d'origine ....

Si quelqu'un sait comment effacé toutes les règles existantes .... lje suis preneur ......

Sub CreateRule()
    Dim colRules As Outlook.Rules
    Dim oRule As Outlook.Rule
    Dim colRuleActions As Outlook.RuleActions
    Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
    Dim oFromCondition As Outlook.TextRuleCondition
    Dim oExceptSubject As Outlook.TextRuleCondition
    Dim oInbox As Outlook.Folder
    Dim oMoveTarget As Outlook.Folder
    Dim tablo() As String
    Dim NomDossier As String
    Dim a As String
    Dim k, f As Integer
    Dim olSpace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder, olInbox As Outlook.MAPIFolder

    Set olSpace = Application.GetNamespace("MAPI")
    Set olInbox = olSpace.GetDefaultFolder(olFolderInbox)
    
   
    
    f = olInbox.Folders.Count

    For k = f To 1 Step -1
    NomDossier = olInbox.Folders.Item(k)
    
    
    
    
    
    'Specify target folder for rule move action
    Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
    'Assume that target folder already exists
    Set oMoveTarget = oInbox.Folders(NomDossier)
    a = NomDossier
 
    tablo = Split(NomDossier, " ")
    
    'Get Rules from Session.DefaultStore object
    Set colRules = Application.Session.DefaultStore.GetRules()
        
    'Create the rule by adding a Receive Rule to Rules collection
    Set oRule = colRules.Create(NomDossier, olRuleReceive)

    'Specify the condition in a ToOrFromRuleCondition object
    'Condition is if the message is from "Dan Wilson"
    Set oFromCondition = oRule.Conditions.Subject
    With oFromCondition
        .Enabled = True
        .Text = tablo
        '.Recipients.Add ("michel rodriguez")
        '.Recipients.ResolveAll
    End With

    'Specify the action in a MoveOrCopyRuleAction object
    'Action is to move the message to the target folder
    Set oMoveRuleAction = oRule.Actions.MoveToFolder
    With oMoveRuleAction
        .Enabled = True
        .Folder = oMoveTarget
    End With

    'Specify the exception condition for the subject in a TextRuleCondition object
    'Exception condition is if the subject contains "fun" or "chat"
    'Set oExceptSubject = _
        'oRule.Exceptions.Subject
    'With oExceptSubject
        '.Enabled = True
        '.Text = Array("fun", "chat")
    'End With

    'Update the server and display progress dialog
    colRules.Save
    Next k
End Sub

Bonne Journée à vous tous ....