Discussion :

[flacdomatmut]

Bonjour, suite à votre excellente aide sur ma macro de règle de sauvegarde des pj je reviens vers vous cette fois pour effectuer une macro qui "range" les mails à
l'arrivé d'un mail. En effet, je désire controler le corps du message pour connaitre sa valeur. J' ai un nombre important de mail qui arrive avec un corps de message identique, je voudrais qu'ils aillent dans un dossier crée préalablement. J'ai trouvé ce code, mais je n'ai pas les connaissances nécéssaire pour bien le modifier. Merci d'avance opour votre aide précieuse.

Le code :

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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)
 
' ***olivier CATTEAU***
 
' 23 avril 2007
 
    Dim olNS As Outlook.namespace
    Dim MyMail As Outlook.MailItem
 
    Dim expediteur
    Set olNS = Application.GetNamespace("MAPI")
    Set MyMail = olNS.GetItemFromID(strID.EntryID)
 
    'MsgBox "nouveau message"
 
    If MyMail.Attachments.Count > 0 Then
 
        expediteur = MyMail.SenderEmailAddress
 
        'on crée le répertoire où mettre les fichiers joints ##########################################################
 
        'c:\temp\pj\ doit déjà exister !!!
 
        Repertoire = "c:\temp\pj\" & expediteur & "\"
 
        If Repertoire <> "" Then
 
            If "" = Dir(Repertoire, vbDirectory) Then
 
                MkDir Repertoire
 
            End If
 
        End If
 
        'on traite les pj
 
        Dim PJ, typeatt
 
        For Each PJ In MyMail.Attachments
            'vérification si c'est une PJ Embedded
 
            typeatt = Isembedded(strID, PJ.Index)
 
            If typeatt = "" Then
 
                If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then
 
                    MsgBox Repertoire & PJ.FileName & " existe !!"
 
                    'si existe copie vers le répertoire old
 
                    If "" = Dir(Repertoire & "old", vbDirectory) Then
 
                        MkDir Repertoire & "old"
 
                    End If
 
                    FileCopy Repertoire & PJ.FileName, Repertoire & "old\" & PJ.FileName
 
                End If
 
                PJ.SaveAsFile Repertoire & PJ.FileName
 
            End If
 
        Next PJ
 
        'drapeau vert
 
        MyMail.FlagIcon = olGreenFlagIcon
 
        'Marque lu
 
        MyMail.UnRead = False
 
        MyMail.Save
 
        'on déplace le mail vers un sous dossier outlook
 
        Dim myDestFolder As Outlook.MAPIFolder
 
        Set myDestFolder = MyMail.Parent.Folders("test")
        MyMail.Move myDestFolder
 
    End If
 
    Set MyMail = Nothing
    Set olNS = Nothing
 
Fin:
 
End Sub
 
 
 
' Function: Fields_Selector
 
' Purpose: View type of attachment
 
' olivier catteau fevrier 2006
 
Function Isembedded(ByVal strEntryID As String, attindex As Integer) As Variant
 
    Dim oSession As MAPI.Session
    ' CDO objects
 
    Dim oMsg As MAPI.Message
    Dim oAttachs As MAPI.Attachments
 
    Dim oAttach As MAPI.Attachment
 
    ' initialize CDO session
 
    On Error Resume Next
 
    Set oSession = CreateObject("MAPI.Session")
    oSession.Logon "", "", False, False
 
    ' get the message created earlier
 
    Set oMsg = oSession.GetMessage(strEntryID)
    ' set properties of the attached graphic that make
 
    ' it embedded and give it an ID for use in an image tag
 
    Set oAttachs = oMsg.Attachments
    Set oAttach = oAttachs.Item(attindex)
    Dim strCID As String
 
    strCID = oAttach.Fields(&H3712001E)
 
    Isembedded = strCID
 
    Set oMsg = Nothing
 
    oSession.Logoff
 
    Set oSession = Nothing
 
End Function

[flacdomatmut]

J'ai modifié le code car je ne veux pas qu'il y ait de traitement des PJ, je veux seulement que le mail avec tel corps de message aille dans tel dossier outlook ( Il me reste à faire l'action de lecture du corps message un if je suppose ) :

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
Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)
 
' ***olivier CATTEAU***
 
' 23 avril 2007
 
    Dim olNS As Outlook.NameSpace
    Dim MyMail As Outlook.MailItem
 
    Dim expediteur
    Set olNS = Application.GetNamespace("MAPI")
    Set MyMail = olNS.GetItemFromID(strID.EntryID)
 
    'MsgBox "nouveau message"
 
    If MyMail.Attachments.Count > 0 Then
 
        expediteur = MyMail.SenderEmailAddress
 
 
        'drapeau vert
 
        MyMail.FlagIcon = olGreenFlagIcon
 
 
 
 
        'on déplace le mail vers un sous dossier outlook
 
        Dim myDestFolder As Outlook.MAPIFolder
 
        Set myDestFolder = MyMail.Parent.Folders("test")
        MyMail.Move myDestFolder
 
    End If
 
    Set MyMail = Nothing
    Set olNS = Nothing
 
Fin:
 
End Sub

[flacdomatmut]

En gros avec mes connaissances rudimentaires en VBA, je ferais cela (c'est surement nul) :

If message.corps = "Bonjour, merci de traiter cette demande" Then

PLACE DANS SOUS DOSSIER

[flacdomatmut]

RE, j'ai trouvé une autre macro plus simple qui deplace un mail a son arrivé en fonction de l'expediteur (plus qu'à modifier la condition). Seulement après test le message n'est pas déplacé quelle est mon erreur :

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)
'---------------------------------------------------------------------------------------
' Procédure : Application_NewMailEx
' Auteur    : Dolphy35
' Site      : http://dolphy35.developpez.com
' Détail    : Permet de déplacer le nouveau message si celui-ci est envoyé par un expéditeur précis
'---------------------------------------------------------------------------------------
'
    'Déclarations
    Dim MonApp As Outlook.Application
    Dim MonMail As Object
    Dim MonNameSpace As Outlook.NameSpace
    Dim MonDossier As Outlook.Folder
 
    'Instance des objets
    Set MonApp = Outlook.Application
    Set MonNameSpace = MonApp.GetNamespace("MAPI")
    Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
    Set MonMail = Application.Session.GetItemFromID(EntryIDCollection)
 
        'Test si l'expéditeur correspond dans ce cas on déplace le mail
        'vers le dossier Temp de votre boîte de réception
        If MonMail.SenderEmailAddress = "pavot.cyprien1e@nomail.fr" Then
            MonMail.Move MonDossier.Folders("DEMANDES")
        End If
 
End Sub

[kuchiky]

Bonjour,

Ton dossier "DEMANDES" est-il un sous dossier de Boîte de Réception ou bien de Boite aux lettres?

[kuchiky]

De plus, j'ai du mal à savoir comment tu fais le test, étant donnée que ce code n'est pas lancable en tant que macro ni utilisable en tant que script.(Apres je raconte peut-être des bêtises)

[flacdomatmut]

DOSSIER boite au lettre

pour le code je l'ai trouvé sur le tuto d'initiation VBA de ce site donc je pense que ca doit marcher :p Je dois faire une mauvaise manip je pense

[Oliv-]

Bonjour,
Pourquoi n'utilises tu pas les REGLES et alertes de OUTLOOK Pour faire cela ?

[kuchiky]

Si le dossier est le sous-dossier de Boîte au lettre tu remplacer ceci:

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
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'---------------------------------------------------------------------------------------
' Procédure : Application_NewMailEx
' Auteur    : Dolphy35
' Site      : http://dolphy35.developpez.com
' Détail    : Permet de déplacer le nouveau message si celui-ci est envoyé par un expéditeur précis
'---------------------------------------------------------------------------------------
'
    'Déclarations
    Dim MonApp As Outlook.Application
    Dim MonMail As Object
    Dim MonNameSpace As Outlook.NameSpace
    Dim MonDossier As Outlook.Folder
 
    'Instance des objets
    Set MonApp = Outlook.Application
    Set MonNameSpace = MonApp.GetNamespace("MAPI")
    Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
    Set MonMail = Application.Session.GetItemFromID(EntryIDCollection)
 
        'Test si l'expéditeur correspond dans ce cas on déplace le mail
        'vers le dossier Temp de votre boîte de réception
        If MonMail.SenderEmailAddress = "pavot.cyprien1e@nomail.fr" Then
            MonMail.Move MonDossier.Parent.Folders("DEMANDES")
        End If
 
End Sub

[Oliv-]

Bonjour,
attention l'événement utilisé renvoi une colllection, c'est à dire qu'il peut renvoyer plusieurs mail arrivés en même temps :

Code :

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

1
2
3
4
5
6
7
8
9
10
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim varEntryIDs
    Dim objItem
    Dim i As Integer
    varEntryIDs = Split(EntryIDCollection, ",")
    For i = 0 To UBound(varEntryIDs)
        Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
        Debug.Print "NewMailEx " & objItem.Subject
    Next
End Sub