Classement automatique des emails ET des rapports (olReport) [Résolu]

[amarcotte]

Bonjour à tous,

J'essaiede créer une macro pour trier automatiquement mes emails. En somme :

• Je sélectionne dans ma boîte de réception le ou les emails à classer
• J'appel la macro "moveToArchive"

Cette macro fait :

• Change l'état du email en "lu"
• Classe le email (ou le rapport) dans le bon répertoire

Le problème : pas de problème pour classer les emails (class = olMail), par contre c'est une autre paire de manche pour les rapports de lecture (classe = olReport) !

En fait, je n'arrive pas à trouver l'expéditeur du rapport de lecture, je n'arrive donc pas à le classer. Bien sûr, quand la classe du message est "olReport", la fonction "SenderEmailAddress" n'existe pas, d'ou le problème !

Mon code :

Code :

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
Sub moveToArchive()
    'Bligoo - March 2008
    'http://bligoo.wordpress.com/
 
    ' OlObjectClass
    ' olMail = 43
    ' olNote = 44
    ' olPost = 45
    ' olReport = 46
    ' olRemote = 47
    ' Liste complète : http://support.microsoft.com/kb/285202/fr
 
    On Error Resume Next
    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
    Dim objNS As Outlook.namespace
    Dim objItem As Object    ' Impossible de mettre "MailItem" ???
 
    Set objNS = Application.GetNamespace("MAPI")
    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
    ' Set objFolder = objNS.Folders("Dossiers 2008")
    ' À retenir : objNS.Folders(”Dossiers personnels”).Folders(”sous dossier”).Folders(”Sous sous dossier”)
    ' Exemple : Set objFolder = objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("MP")
    Set objFolder = objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("MP")
 
    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
 
            Select Case objItem.Class
 
                Case olMail:    ' Courriel
 
                    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
                    NomExp = objItem.SenderName
                    AdresseExp = objItem.SenderEmailAddress
                    Domaine = Split(AdresseExp, "@")
                    Select Case Domaine(1)
                        Case "mailingprocess.com":
                            Select Case Domaine(0)    ' Nom de l'expéditeur
 
                                Case "SRVVALIPOST1"
 
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Serveur.Valipost")
                                Case "destineo"
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Serveur.Valipost").Folders("Bordereaux")
                                Case Else
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("MP")
                            End Select
                        Case "routage-et-marketing.com":
                            objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("RMP")
                        Case "bip.laposte.fr"
                            objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("La Poste").Folders("info@bip.laposte.fr")
                    End Select
 
                Case olReport:    ' Rapport : Courriel Lu uniquement
 
                    objItem.UnRead = False    '[asy]Le mail passe dans le statut lu
                    ' Impossible d'obtenir le nom de l'expéditeur
                    ' NomExp = objItem.SenderName
                    ' AdresseExp = objItem.SenderEmailAddress
                    ' Domaine = Split(AdresseExp, "@")
 
 
                    ' objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("MP").Folders("Lu")
 
            End Select
 
        End If
 
    Next
 
    Set objItem = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing
 
End Sub

code qui pose problème

Code :

1
2
3
4
5
6
7
 Case olReport:    ' Rapport : Courriel Lu uniquement
 
                    objItem.UnRead = False    '[asy]Le mail passe dans le statut lu
                    ' Impossible d'obtenir le nom de l'expéditeur
                    ' NomExp = objItem.SenderName
                    ' AdresseExp = objItem.SenderEmailAddress
                    ' Domaine = Split(AdresseExp, "@")

Le type olReport n'ayant pas les mêmes propriétés que olMail, impossible de trouver de qui vient le rapport de lecture. Le courrier étant envoyé à plusieurs destinataires, même si je regarde à l'intérieur du "body", je ne trouve pas de qui le message m'est envoyé ! Le plus drôle est qu'il est bien possible de faire répondre mais à partir de l'interface. Dur dur la vie !

Moi j'ai bien beau chercher, je n'ai rien trouvé pour m'en sortir ! Au secours !

[Dolphy35]

Salut,

je confirme il n'y a aucunes propriétés permettant d'avoir l'expéditeur depuis un ReportItem. Normalement tu as l'adresse mail de l'expéditeur du report dans le body mais là il te faut coder un bon traitement sur chaîne.

Je ne connais pas mais regarde du côté de CDO, il reprend pas mal de faille d'outlook.


Dolphy

[amarcotte]

Hello Dolphy35,

Merci pour la réponse, c'est bien ce que je pensais ! C'est quand même incroyable qu'il soit impossible de retrouver l'expéditeur. Le traitement du corp du message n'est pas vraiment utile, le nom de l'expéditeur y est mais pas nécessairement son adresse email !

Concernant le Collaboration Data Objects (CDO), as-tu un site source à me suggérer ?

Merci encore pour ta réponse rapide,

[Dolphy35]

re,



Wouapaaa !!!

c'est pas CDO mais redemption

http://www.dimastr.com/redemption


Dolphy

[amarcotte]

J'ai honte j'ai honte !

Merci pour la suggestion, je regarde ça !

À bientôt,

André

[Dolphy35]

Envoyé par amarcotte

J'ai honte j'ai honte !

c'est plutôt moi j'ai carrément confondu les deux

Bon Week

[amarcotte]

Yes ! Redemption a la solution ! Juste un petit bout, mais qui donne exactement le résultat recherché :

Code :

1
2
3
4
5
6
Dim sItem, oItem
Set sItem = CreateObject("Redemption.SafeMailItem")
Set oItem = Application.Session.GetDefaultFolder(6).Items(1) 'get first e-mail from the Inbox, can be any other item
sItem.Item = oItem
PrSenderEmail = &HC1F001E
MsgBox sItem.Fields(PrSenderEmail)

MsgBox sItem.Fields(PrSenderEmail) envoi le nom du destinataire, que ce soit un email ou un rapport. Que du bonheur !

Merci pour ton aide, c'était une excellente suggestion !

[amarcotte]

Pour les fana du code, la technique utilisé :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Function TrouveExpediteur(IDUnique As String) As String
 
Dim sItem, oItem
 
    Set sItem = CreateObject("Redemption.SafeMailItem")
    Set oItem = Application.Session.GetItemFromID(IDUnique) ' Application.Session.GetDefaultFolder(6).Items(1) 'get first e-mail from the Inbox, can be any other item
 
    sItem.Item = oItem
    PrSenderEmail = &HC1F001E
 
    TrouveExpediteur = sItem.Fields(PrSenderEmail)
 
    Set sItem = Nothing
    Set oItem = Nothing
 
End Function

Il s'agit en fait de passer en paramètre l'ID unique du message en cours pour trouver l'adresse destinataire. La fonction principale (je sais, il reste à optimiser !) :

Code :

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
Sub moveToArchive()
'Bligoo - March 2008
'http://bligoo.wordpress.com/
 
 ' OlObjectClass
 '  olMail = 43
 '  olNote = 44
 '  olPost = 45
 '  olReport = 46
 '  olRemote = 47
 '  Liste complète : http://support.microsoft.com/kb/285202/fr
 
    On Error Resume Next
    Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
    Dim objNS As Outlook.NameSpace
    Dim objItem As Object ' Impossible de mettre "MailItem" ???
 
    Set objNS = Application.GetNamespace("MAPI")
    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
    ' Set objFolder = objNS.Folders("Dossiers 2008")
    ' À retenir : objNS.Folders(”Dossiers personnels”).Folders(”sous dossier”).Folders(”Sous sous dossier”)
    ' Exemple : Set objFolder = objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("MP")
    Set objFolder = objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("MP")
 
    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
        NomExp = TrouveExpediteur(objItem.EntryID)
            Select Case objItem.Class
                Case olMail:    ' Courriel
                    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
                    ' NomExp = objItem.SenderName
                    AdresseExp = objItem.SenderEmailAddress
                    Domaine = Split(AdresseExp, "@")
                    Select Case Domaine(1)
                        Case "mailingprocess.com":
                            Select Case Domaine(0)  ' Nom de l'expéditeur
                                Case "SRVVALIPOST1"
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Serveur.Valipost")
                                Case "destineo"
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Serveur.Valipost").Folders("Bordereaux")
                                Case Else
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("MP")
                            End Select
                        Case "routage-et-marketing.com":
                            objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("RMP")
                        Case "bip.laposte.fr"
                            objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("La Poste").Folders("info@bip.laposte.fr")
                        Case "laposte.fr"
                            objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("La Poste")
                        Case "valipost.com":
                            Select Case Domaine(0)  ' Nom de l'expéditeur
                                Case "rmp"
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Serveur.Valipost")
                                Case Else
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Valipost")
                            End Select
                    End Select
                Case olReport:  ' Rapport : Courriel Lu uniquement
                    objItem.UnRead = False '[asy]Le mail passe dans le statut lu
                    ' Impossible d'obtenir le nom de l'expéditeur
                    ' NomExp = objItem.SenderName
                     AdresseExp = NomExp
                     Domaine = Split(AdresseExp, "@")
                    Select Case Domaine(1)
                        Case "mailingprocess.com":
                            Select Case Domaine(0)  ' Nom de l'expéditeur
                                Case "SRVVALIPOST1"
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Serveur.Valipost")
                                Case "destineo"
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Serveur.Valipost").Folders("Bordereaux")
                                Case Else
                                    objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("MP").Folders("Lu")
                            End Select
                        Case "routage-et-marketing.com":
                            objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("Interne").Folders("RMP").Folders("Lu")
                        Case "laposte.fr"
                            objItem.Move objNS.Folders("Dossiers 2008").Folders("Boîte de réception").Folders("La Poste")
                    End Select
            End Select
        End If
    Next
 
    Set objItem = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing
 
End Sub

Ça fonctionne parfaitement, c'est bien à se demander pourquoi Outlook sans Redemption n'était pas capable de faire la "job".

Encore merci pour la suggestion !