Bonjour à tous!
Désolé pour ce long titre mais voici en gros ce que je cherche à faire:
En cours:
Extraire (tableau ou autre) l'adresse complète de toutes les personnes d'un mail. Expéditeur, destinataires, copie, sous format string pour ensuite me permettre de ranger le mail suivant mes règles.
En long:
Je souhaite trier efficacement mes mails et rentrer des règles trés précises via VBA basées sur l'adresse des destinataires/expéditeurs/personnes en copie.
En gros pour des extérieures à mon entreprise je regarde leur adresse "@entrepriseA" et je range dans le dossier entrepriseA, etc... qu'ils soient expediteurs, destinataires ou en copie.
(ca ca peut se faire avec des règles classiques mais j'ai vraiment trop d'entreprises différentes)
La ou ca se corse c'est quand je veux regarder les mails en interne.
C'est a dire que la dernière règle serait de ranger dans "interne" les mails qui ne sortent strictement pas. Si mes règles précédentes sont robustes alors cette dernières serait obsolète puisque les mails internes seraient tous les mails restants, mais bon, ne nous basons pas la dessus, surtout que j'aimerai m'accorder la possibilité de ranger suivant d'autres règles customs que je ferai à la main.
Pour ce faire je me suis dit que le mieux serait de pouvoir extraire toutes les adresses des mails dans mon dossier de rangement "A Ranger" et ensuite de m'amuser avec.
j'ai déjà ce code bricolé moi même et cette fonction obtenue sur un autre forum:
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 Sub Test() Dim MAPI As NameSpace Dim Source As Folder, Dest As Folder Dim myInbox As Outlook.Folder Dim mail As MailItem Dim AddMail As String Dim myItem As Object Set MAPI = Application.GetNamespace("MAPI") Set myInbox = MAPI.GetDefaultFolder(olFolderInbox) 'Get the inbox folder Set Source = myInbox.Parent.Folders("test1") 'Set the destination folder (main folder) Set Dest = myInbox.Parent.Folders("test2") 'Use this for a sub folder 'Set Dest = MAPI.Folders("Test").Folders("MySubFolder") 'Visit each mail For Each mail In Source.Items 'Match with our criteria? AddMail = GetSmtpAddress(mail) If InStr(AddMail, "@entrepriseA") <> 0 Then 'Move it to the other folder mail.Move Dest End If Next ' Set myItem = myItems.Find("[SenderName] = 'Dan Wilson'") ' While TypeName(myItem) <> "Nothing" ' myItem.Move myDestFolder ' Set myItem = myItems.FindNext ' Wend End SubJ'ai pas mal cherché mais je n'ai pas trouvé de choses adéquat.
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 Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem) Dim recips As Outlook.Recipients Dim recip As Outlook.Recipient Dim pa As Outlook.PropertyAccessor Const PR_SMTP_ADDRESS As String = _ "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" Set recips = mail.Recipients For Each recip In recips Set pa = recip.PropertyAccessor Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS) Next End Sub Public Function GetSmtpAddress(mail As MailItem) On Error GoTo On_Error GetSmtpAddress = "" Dim Report As String Dim Session As Outlook.NameSpace Set Session = Application.Session If mail.SenderEmailType <> "EX" Then GetSmtpAddress = mail.SenderEmailAddress Else Dim senderEntryID As String Dim sender As AddressEntry Dim PR_SENT_REPRESENTING_ENTRYID As String PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102" senderEntryID = mail.PropertyAccessor.BinaryToString( _ mail.PropertyAccessor.GetProperty( _ PR_SENT_REPRESENTING_ENTRYID)) Set sender = Session.GetAddressEntryFromID(senderEntryID) If sender Is Nothing Then Exit Function End If If sender.AddressEntryUserType = olExchangeUserAddressEntry Or _ sender.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then Dim exchangeUser As exchangeUser Set exchangeUser = sender.GetExchangeUser() If exchangeUser Is Nothing Then Exit Function End If GetSmtpAddress = exchangeUser.PrimarySmtpAddress Exit Function Else Dim PR_SMTP_ADDRESS PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" GetSmtpAddress = sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS) End If End If Exiting: Exit Function On_Error: MsgBox "error=" & Err.Number & " " & Err.Description Resume Exiting End Function
Si des personnes peuvent m'éclairer je me ferai une joie de les remercier
@ plus
Thibaut
Partager