Discussion :

[starkoala]

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 Sub

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

J'ai pas mal cherché mais je n'ai pas trouvé de choses adéquat.
Si des personnes peuvent m'éclairer je me ferai une joie de les remercier

@ plus

Thibaut

[Oliv-]

Bonjour,
A quel moment veux tu effectuer ton classement ? lors de l'envoi, lors de la reception, sur ordre,...

Change ton code

Code :

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

  If InStr(AddMail, "@entrepriseA") <> 0 Then

par

Code :

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

1
2
 
  If InStr(1,AddMail, "@entrepriseA",vbTextCompare)> 0 Then

Qu'est ce qui ne fonctionne pas sinon dans ton code ?

[starkoala]

Bonjour,

Merci pour la réponse et la correction.

Je lance le code quand je le souhaite, pas besoin de règles envoie ni reception.
A vrai dire ce bout de code marche bien pour trier les mails suivant leur envoyeur. En revanche je ne sait pas comment extraire les adresses des personnes destinataires ni de celles en copie.

Je souhaite pouvoir le faire pour effectuer un tri plus précis en implémentant de nouveaux critères dans mon code.

Merci

Thibaut

[Oliv-]

Salut,

Voici un exemple à partir d'un Email Ouvert

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
 
 
Private Sub test_adresse_SMTP_DESTINATAIRES()
    Set Oitem = ActiveInspector.CurrentItem    'désigne l'élément actif càd le mail le contact ou rdv...
    Dim DEST As Recipient
    Dim Email As String
    Dim interne As Long
    Dim externe As Long
    Dim Nb_A As Long
    Dim Nb_CC As Long
 
    interne = 0
    externe = 0
    Nb_A = 0
    Nb_CC = 0
 
    For Each DEST In Oitem.Recipients
        Email = GetSMTPAddressForRecipient(DEST)
        If InStr(1, Email, "grassavoye.com", vbTextCompare) > 0 Then
            interne = interne + 1
        Else
            externe = externe + 1
        End If
 
 
        'olBCC =3 Le destinataire est spécifié dans la propriété BCC de l'élément.
        'olCC =2 Le destinataire est spécifié dans la propriété CC de l'élément.
        'olOriginator =0 Expéditeur de l'élément.
        'olTo =1 Le destinataire est spécifié dans la propriété To de l'élément.
 
        Select Case DEST.Type
        Case olTo
            Nb_A = Nb_A + 1
        Case olCC
            Nb_CC = Nb_CC + 1
        End Select
 
        MsgBox DEST.Name & vbCr & DEST.Type & vbCr & DEST.Address & vbCr & Email
    Next DEST
 
    MsgBox "nombre destinataires " & vbCr & " internes :" & interne & vbCr & "externes: " & externe & vbCr & "A:" & Nb_A & vbCr & "CC:" & Nb_CC
 
End Sub
 
 
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'---------------------------------------------------------------------------------------
' Procedure : GetSMTPAddressForRecipient
' Author    : Oliv-
' Date      : 21/01/2015
' Purpose   : Obtenir l'adresse SMTP =xxx@xxx.xxx
'---------------------------------------------------------------------------------------
'Dim recip As Outlook.Recipient
'pas de adresse SMTP si Contact d'origine EXCHANGE mais copié dans Pop
    GetSMTPAddressForRecipient = ""
    On Error GoTo fin
    Dim pa As Outlook.propertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set pa = recip.propertyAccessor
    'Debug.Print recip.Name & " SMTP=" _
     & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
fin:
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip
End Function

[starkoala]

Salut,

franchement génial je vais déjà pouvoir bien m'amuser avec cela, je devrais sans doute arriver à mes fins.

Je mettrais en résolu dans quelques jours si je n'ai pas d'autres questions en rapport.

merci beaucoup.

Thibaut

[starkoala]

Bonjour,

J'ai bien implémenter le code et ca fonctionne bien,

En revanche pour la fonction getsmtpadress de mon premier post je n'ai pas le mail de l'envoyeur quand l'adresse mail à été supprimée du serveur...

Y a til une solution? C'est dommage que ce soit ausi compliqué pour obtenir l'adresse de l'expediteur
(senderemailadresse ne fonctione pas non plus dans ce cas)

Merci

Thibaut

[Oliv-]

Moi j'utilise

Code :

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

1
2
3
4
5
6
7
8
Private Function Get_sender_exchange(oitem As Outlook.MailItem) As String
    Dim oEU As Outlook.exchangeUser
    On Error Resume Next
    Set oEU = oitem.sender.GetExchangeUser
 
    Get_sender_exchange = oEU.PrimarySmtpAddress
    If Get_sender_exchange = "" Then Get_sender_exchange = oitem.SenderEmailAddress
End Function

si tu obtiens une adresse du type

/O=EXCHANGELABS/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=E9788A9E705E4FC2980BEE2AFA2FD800-CBBI

c'est que c'est une adresse interne. (à priori)

[starkoala]

Bonsoir.

Oui tout a fait. En revanvhe jairai aimé avoir vraiment l'adresse si possible.
Parceque je souhaite y appliquer des critères.

Y a t il un moyen?

Merci

Thibaut

[Oliv-]

en fait tu obtiens bien "une des adresses" !

peut être dans les en-têtes du mail

[starkoala]

Bonjour,

Bon je me suis débrouillé mais dommage que dans le cas précédent nous ne pouvons rtrouver l'adresse "truc.bidule@machin.com"

Hopla je passe en résolu,

Merci

[Oliv-]

Salut,

Je pense que c'est dans les en-têtes internet -->"From:"

-->Fichier/Informations/Propriétés/en-têtes internet

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
Sub test_GetToFromHeader()
Dim objMail As Outlook.MailItem
 
Set objMail = ActiveInspector.CurrentItem
MsgBox GetFromFromHeader(objMail)
End Sub
 
Function GetFromFromHeader(objMail As Outlook.MailItem) As String
'---------------------------------------------------------------------------------------
' Procedure : GetToFromHeader
' Author    : OLIV- from original code brettdj
' Date      : 04/06/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim objRegex As Object
    Dim objRegM As Object
    Dim MailHeader As String
    Dim ExtractText As String
    Dim i
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F"
    MailHeader = objMail.propertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
 
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .ignorecase = True
        .Pattern = "(\n)From:.*<(.+)>"
        If .test(MailHeader) Then
            Set objRegM = .Execute(MailHeader)
            For i = 0 To objRegM(0).submatches.Count - 1
            If InStr(1, objRegM(0).submatches(i), "@", vbTextCompare) Then
            GetFromFromHeader = objRegM(0).submatches(i)
            Exit For
            End If
            Next i
        Else
            GetFromFromHeader = "No match"
        End If
    End With
End Function