faire un vba transféré mail vers divers dossier

**anthony38440** · 28/05/2019, 08h26

Je suis plus que novice avec VBA
J’ai des mail qui viennent de (notifications@railnova.eu) qui dans le titre contient un numéro d’engin surligner en jaune : [info][code défaut] Code défaut sur 75453: (toujours 5 chiffres)

Je voudrais envoyer ces mail vers les dossier concernant le numéro de l’engin (J’ai ai un peu plus de 100)

**Oliv-** · 28/05/2019, 09h59

Salut,
tu veux lancer cela 1 seule fois ou avoir un automatisme ?

**anthony38440** · 28/05/2019, 10h07

que sa soit automatique quand je reçoit les mail

**Oliv-** · 28/05/2019, 12h30

Voici un exemple qui devrait faire le job

il te faut un sous dossier de la boite de réception qui s'appelle ici "Tests", tu peux le renommer dans le code

pour traiter les mails déjà arrivés, à mettre dans un module

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Dim OL As Object
 
Sub LanceClassement_code_defaut()
 
    Dim myNamespace As Outlook.Namespace
    Dim myFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim filter
 
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    Set myNamespace = OL.GetNamespace("MAPI")
    Set myFolder = _
            myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myFolder.Items
    filter = "@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0037001E" _
            & Chr(34) & " ci_phrasematch " & "'[info][code défaut]'"
 
    Set myRestrictItems = myItems.Restrict(filter)
    For i = myRestrictItems.Count To 1 Step -1
        Dim DossierName
        DossierName = Num(myRestrictItems(i).Subject, 1)
        Set objFolderDestination = getDestinationFolder("Tests", DossierName)
        myRestrictItems(i).Move objFolderDestination
    Next
 
 
 
End Sub

pour automatiser à la réception, il faut régler le niveau de sécurité des macros et les activer.

A mettre dans thisOutlookSession

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'---------------------------------------------------------------------------------------
' Procedure : Application_NewMailEx
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Classe Les Emails a la reception dans le dossier si le sujet contient la structure #XM
'---------------------------------------------------------------------------------------
'
    Dim objFolderDestination As MAPIFolder
    Dim varEntryIDs
    Dim Item
    Dim i As Integer
    varEntryIDs = Split(EntryIDCollection, ",")
    For i = 0 To UBound(varEntryIDs)
        Set Item = Application.Session.GetItemFromID(varEntryIDs(i))
        If Not Item.Class = olMail Then GoTo fin
        Dim DossierName
 
 
        If InStr(1, Item.Subject, "[info][code défaut]", vbTextCompare) Then
            DossierName = Num(Item.Subject, 1)
            Set objFolderDestination = getDestinationFolder("Tests", DossierName)
            Item.Move objFolderDestination
        End If
    Next
fin:
End Sub

fonction utilisée par les macros à mettre dans le module

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Function getDestinationFolder(ParentName, FolderName) As Folder
'---------------------------------------------------------------------------------------
' Procedure : getDestinationFolder
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Renvoi le sous dossier d'un dossier avec création
'---------------------------------------------------------------------------------------
'
    Dim objNS As Namespace
    Dim objFolderParent As MAPIFolder
    Dim objFolderDestination As MAPIFolder
    On Error Resume Next
    Set objNS = Application.GetNamespace("MAPI")
    Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders(ParentName)
    If TypeName(objFolderParent) = "Nothing" Then
        Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders.Add(ParentName)
    End If
    Set objFolderDestination = objFolderParent.Folders(FolderName)
    If TypeName(objFolderDestination) = "Nothing" Then
        Set objFolderDestination = objFolderParent.Folders.Add(FolderName)
    End If
    Set getDestinationFolder = objFolderDestination
End Function
 
Function Num(chaine, n)
    Set obj = CreateObject("vbscript.regexp")
    obj.Global = True
    obj.Pattern = "\d+"
    Set a = obj.Execute(chaine)
    If a.Count > 0 Then Num = a(n - 1) Else Num = ""
End Function

**anthony38440** · 28/05/2019, 12h45

si je comprend bien il fautt que je copie les 3 fiche que tu as mis dans la macro et ca vas marcher ?

**Oliv-** · 28/05/2019, 14h03

Il y aura peut être quelques adaptations à faire...

Tu peux aussi créer des règles (sans programmation) 1 par engin pour le classement automatique !

**anthony38440** · 28/05/2019, 14h27

Envoyé par Oliv-

Il y aura peut être quelques adaptations à faire...

Tu peux aussi créer des règles (sans programmation) 1 par engin pour le classement automatique !

merci pour votre aide oui j'ai du faire quelque modification, j'ai recu un mail et ca m'as pas trier tout seul

**anthony38440** · 28/05/2019, 14h31

dans module jai mis

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Function getDestinationFolder(ParentName, FolderName) As Folder
'---------------------------------------------------------------------------------------
' Procedure : getDestinationFolder
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Renvoi le sous dossier d'un dossier avec création
'---------------------------------------------------------------------------------------
'
    Dim objNS As NameSpace
    Dim objFolderParent As MAPIFolder
    Dim objFolderDestination As MAPIFolder
    On Error Resume Next
    Set objNS = Application.GetNamespace("MAPI")
    Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders(ParentName)
    If TypeName(objFolderParent) = "Nothing" Then
        Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders.Add(ParentName)
    End If
    Set objFolderDestination = objFolderParent.Folders(FolderName)
    If TypeName(objFolderDestination) = "Nothing" Then
        Set objFolderDestination = objFolderParent.Folders.Add(FolderName)
    End If
    Set getDestinationFolder = objFolderDestination
End Function
 
Function Num(chaine, n)
    Set obj = CreateObject("vbscript.regexp")
    obj.Global = True
    obj.Pattern = "\d+"
    Set a = obj.Execute(chaine)
    If a.Count > 0 Then Num = a(n - 1) Else Num = ""
End Function
 
Sub LanceClassement_code_defaut(itm As Outlook.MailItem)
 Dim OL As Object
    Dim myNamespace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim filter
 Dim i As Integer
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    Set myNamespace = OL.GetNamespace("MAPI")
    Set myFolder = _
            myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myFolder.Items
    filter = "@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0037001E" _
            & Chr(34) & " ci_phrasematch " & "'[info][code défaut]'"
 
    Set myRestrictItems = myItems.Restrict(filter)
    For i = myRestrictItems.Count To 1 Step -1
        Dim DossierName
        DossierName = Num(myRestrictItems(i).Subject, 1)
        Set objFolderDestination = getDestinationFolder(".telediag", DossierName)
        myRestrictItems(i).Move objFolderDestination
    Next
 
 
 
End Sub

et dans Thisoutlooksession

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Function getDestinationFolder(ParentName, FolderName) As Folder
'---------------------------------------------------------------------------------------
' Procedure : getDestinationFolder
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Renvoi le sous dossier d'un dossier avec création
'---------------------------------------------------------------------------------------
'
    Dim objNS As NameSpace
    Dim objFolderParent As MAPIFolder
    Dim objFolderDestination As MAPIFolder
    On Error Resume Next
    Set objNS = Application.GetNamespace("MAPI")
    Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders(ParentName)
    If TypeName(objFolderParent) = "Nothing" Then
        Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders.Add(ParentName)
    End If
    Set objFolderDestination = objFolderParent.Folders(FolderName)
    If TypeName(objFolderDestination) = "Nothing" Then
        Set objFolderDestination = objFolderParent.Folders.Add(FolderName)
    End If
    Set getDestinationFolder = objFolderDestination
End Function
 
Function Num(chaine, n)
    Set obj = CreateObject("vbscript.regexp")
    obj.Global = True
    obj.Pattern = "\d+"
    Set a = obj.Execute(chaine)
    If a.Count > 0 Then Num = a(n - 1) Else Num = ""
End Function
 
Sub LanceClassement_code_defaut(itm As Outlook.MailItem)
 Dim OL As Object
    Dim myNamespace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim filter
 Dim i As Integer
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    Set myNamespace = OL.GetNamespace("MAPI")
    Set myFolder = _
            myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myFolder.Items
    filter = "@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0037001E" _
            & Chr(34) & " ci_phrasematch " & "'[info][code défaut]'"
 
    Set myRestrictItems = myItems.Restrict(filter)
    For i = myRestrictItems.Count To 1 Step -1
        Dim DossierName
        DossierName = Num(myRestrictItems(i).Subject, 1)
        Set objFolderDestination = getDestinationFolder(".telediag", DossierName)
        myRestrictItems(i).Move objFolderDestination
    Next
 
 
 
End Sub

**Oliv-** · 28/05/2019, 16h40

et ça marche ? tu as du ajouter une règle avec l'action exécuter un script ?

**anthony38440** · 29/05/2019, 08h14

j’ai un problème est il possible de filtre par notifications@railnova.eu et juste récupéré dans le titre le Numéro de l'engin car tout les message sont pas tous écrit pareil

Après quand je suit dans VBA la macro marche mais arrive pas a la mettre dans une règle car je trouve pas le nom du script

**Christian (Railnova)** · 29/05/2019, 10h18

@anthony : tu peux aussi utiliser l’API Railfleet avec VBA ou Python ça serait plus simple que de parser les emails. Tu peux écrire un mail à s u p p p o r t @ r a i l n o v a . e u et on pourra t’aider. Christian (fondateur Railnova)

**Oliv-** · 29/05/2019, 15h09

Mets cela dans thisOutlookSession , il ne faut rien changer ! Ensuite tu fermes Outlook en enregistrant les modifications dans VBAPROJECT et tu relances Outlook en activant les macros
si la question n'est pas posée regarde là
https://www.developpez.net/forums/bl...curite-macros/

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'---------------------------------------------------------------------------------------
' Procedure : Application_NewMailEx
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Classe Les Emails a la reception dans le dossier si le sujet contient la structure #XM
'---------------------------------------------------------------------------------------
'
    Dim objFolderDestination As MAPIFolder
    Dim varEntryIDs
    Dim Item
    Dim i As Integer
    varEntryIDs = Split(EntryIDCollection, ",")
    For i = 0 To UBound(varEntryIDs)
        Set Item = Application.Session.GetItemFromID(varEntryIDs(i))
        If Not Item.Class = olMail Then GoTo fin
        Dim DossierName
 
       ' If InStr(1, Item.Subject, "[info][code défaut]", vbTextCompare) Then
        If InStr(1, Item.Sender, "notifications@railnova.eu", vbTextCompare) Then
            DossierName = Num(Item.Subject, 1)
            Set objFolderDestination = getDestinationFolder("Tests", DossierName)
            Item.Move objFolderDestination
        End If
    Next
fin:
End Sub

et dans un module cela

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
Dim OL As Object
 
 
Sub test_email_en_cours()
    Set MonEmail = ActiveInspector.CurrentItem
     Dim DossierName
        DossierName = Num(MonEmail.Subject, 1)
        Set objFolderDestination = getDestinationFolder(".telediag", DossierName)
        If Not objFolderDestination Is Nothing Then
            MonEmail.Move objFolderDestination
        End If
End Sub
 
Sub LanceClassement_code_defaut()
 
    Dim myNamespace As Outlook.NameSpace
    Dim myFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim filter
 
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    Set myNamespace = OL.GetNamespace("MAPI")
    Set myFolder = _
            myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myFolder.Items
    'filtre sur le contenu du sujet
    filter = "@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0037001E" _
            & Chr(34) & " ci_phrasematch " & "'[info][code défaut]'"
    'filtre sur l'expéditeur
    filter = "@SQL=" & Chr(34) & "urn:schemas:mailheader:sender" _
            & Chr(34) & " ci_phrasematch " & "'notifications@railnova.eu'"
 
 
    Set myRestrictItems = myItems.Restrict(filter)
    For i = myRestrictItems.Count To 1 Step -1
        Dim DossierName
        DossierName = Num(myRestrictItems(i).Subject, 1)
        Set objFolderDestination = getDestinationFolder(".telediag", DossierName)
        If Not objFolderDestination Is Nothing Then
            myRestrictItems(i).Move objFolderDestination
        End If
    Next
 
 
 
End Sub
 
 
Function getDestinationFolder(ParentName, FolderName) As Folder
'---------------------------------------------------------------------------------------
' Procedure : getDestinationFolder
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Renvoi le sous dossier d'un dossier avec création
'---------------------------------------------------------------------------------------
'
    Dim objNS As NameSpace
    Dim objFolderParent As MAPIFolder
    Dim objFolderDestination As MAPIFolder
    On Error Resume Next
    Set objNS = Application.GetNamespace("MAPI")
    Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders(ParentName)
    If TypeName(objFolderParent) = "Nothing" Then
        Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders.Add(ParentName)
    End If
    Set objFolderDestination = objFolderParent.Folders(FolderName)
    If TypeName(objFolderDestination) = "Nothing" Then
        Set objFolderDestination = objFolderParent.Folders.Add(FolderName)
    End If
    Set getDestinationFolder = objFolderDestination
End Function
 
Function Num(chaine, n)
    Set obj = CreateObject("vbscript.regexp")
    obj.Global = True
    obj.Pattern = "\d+"
    Set a = obj.Execute(chaine)
    If a.Count > 0 Then Num = a(n - 1) Else Num = ""
End Function

**anthony38440** · 12/06/2019, 06h44

merci beaucoup c'est le top!

faire un vba transféré mail vers divers dossier

VBA Outlook

Discussions similaires

Partager

Partager