1. #1
    Candidat au Club
    Homme Profil pro
    chef de projets
    Inscrit en
    janvier 2018
    Messages
    6
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Seine Maritime (Haute Normandie)

    Informations professionnelles :
    Activité : chef de projets

    Informations forums :
    Inscription : janvier 2018
    Messages : 6
    Points : 2
    Points
    2

    Par défaut Trier déplacer mails avec adresses + obtenir adresse from to copy etc

    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

  2. #2
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 308
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 308
    Points : 5 749
    Points
    5 749
    Billets dans le blog
    16

    Par défaut

    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 ?

  3. #3
    Candidat au Club
    Homme Profil pro
    chef de projets
    Inscrit en
    janvier 2018
    Messages
    6
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Seine Maritime (Haute Normandie)

    Informations professionnelles :
    Activité : chef de projets

    Informations forums :
    Inscription : janvier 2018
    Messages : 6
    Points : 2
    Points
    2

    Par défaut

    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

  4. #4
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 308
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 308
    Points : 5 749
    Points
    5 749
    Billets dans le blog
    16

    Par défaut

    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

  5. #5
    Candidat au Club
    Homme Profil pro
    chef de projets
    Inscrit en
    janvier 2018
    Messages
    6
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Seine Maritime (Haute Normandie)

    Informations professionnelles :
    Activité : chef de projets

    Informations forums :
    Inscription : janvier 2018
    Messages : 6
    Points : 2
    Points
    2

    Par défaut

    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

  6. #6
    Candidat au Club
    Homme Profil pro
    chef de projets
    Inscrit en
    janvier 2018
    Messages
    6
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Seine Maritime (Haute Normandie)

    Informations professionnelles :
    Activité : chef de projets

    Informations forums :
    Inscription : janvier 2018
    Messages : 6
    Points : 2
    Points
    2

    Par défaut

    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

  7. #7
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 308
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 308
    Points : 5 749
    Points
    5 749
    Billets dans le blog
    16

    Par défaut

    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)

  8. #8
    Candidat au Club
    Homme Profil pro
    chef de projets
    Inscrit en
    janvier 2018
    Messages
    6
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Seine Maritime (Haute Normandie)

    Informations professionnelles :
    Activité : chef de projets

    Informations forums :
    Inscription : janvier 2018
    Messages : 6
    Points : 2
    Points
    2

    Par défaut

    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

  9. #9
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 308
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 308
    Points : 5 749
    Points
    5 749
    Billets dans le blog
    16

    Par défaut

    en fait tu obtiens bien "une des adresses" !

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

  10. #10
    Candidat au Club
    Homme Profil pro
    chef de projets
    Inscrit en
    janvier 2018
    Messages
    6
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Seine Maritime (Haute Normandie)

    Informations professionnelles :
    Activité : chef de projets

    Informations forums :
    Inscription : janvier 2018
    Messages : 6
    Points : 2
    Points
    2

    Par défaut

    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

  11. #11
    Expert confirmé
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    3 308
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 3 308
    Points : 5 749
    Points
    5 749
    Billets dans le blog
    16

    Par défaut

    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

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. [Mail & PHP] Forcer l'adresse mail du "from"
    Par Life Hunter dans le forum Apache
    Réponses: 10
    Dernier message: 05/09/2008, 23h52
  2. Envoi de mail avec adresse relative
    Par Didier77 dans le forum Access
    Réponses: 3
    Dernier message: 01/09/2006, 11h11
  3. probleme envoi de mail avec certaines adresses
    Par killerhertz dans le forum ASP
    Réponses: 2
    Dernier message: 18/08/2006, 12h03
  4. Réponses: 1
    Dernier message: 05/04/2006, 23h22
  5. [PHPMailer] Les mails avec une adresse extérieure ne partent pas
    Par captaindidi dans le forum Bibliothèques et frameworks
    Réponses: 5
    Dernier message: 06/01/2006, 19h11

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo