Discussion :

[ekodante]

Bonjour,

Configuration actuelle :
1 mail par defaut : toto@tutu.fr (et 2 groupe de distribution : tata@tutu.fr et tonton@tutu.fr).

a l'heure actuelle, lorsque je reçois un mail sur tata ou tonton @tutu.fr, le header du mail indique ce dernier.
j'ai créé 2 compte smtp qui peuvent répondre avec tata et tonton. Mais le problème c'est que ce n'est pas automatique puisque le compte qui répond par défaut à ces mails reste toto@tutu.fr (compte principale qui reçois les mails et groupes de distri), je me retrouve donc a modifier a chaque fois a la main le compte d'envoi.

Je recherche activement une macro qui puis (vous l'aurez compris) :
1- vérifier le récipient qui reçois le mail (toto tata ou tonton).
2- Grace à cette donnée récupéré en 1, remplacer le champ "de" (expéditeur) par le compte (smtp configuré) ou l'adresse tata tonton ou tutu directement.

J'ai un peu écumé pas mal de forum et n'ai pas trouvé de réponse viable.

Par avance merci

[Oliv-]

Bonjour,

Ok je vois bien ton soucis, le problème c'est de retrouver l'adresse de destination.

A PARTIR DU MAIL RECU

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
 
 
Sub test()
    Dim Oitem As Object
    Set Oitem = ActiveInspector.CurrentItem    'désigne l'élément actif càd le mail le contact ou rdv...
    If Oitem.Class <> olMail Then Exit Sub
 
    MsgBox GetToFromHeader(Oitem)
End Sub
 
 
Function GetToFromHeader(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, j
    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")
    Dim Patterns
    Patterns = Array("\nTo:.+<([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})>$", _
                     "\nTo:.([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})\b")
 
    For j = LBound(Patterns) To UBound(Patterns)
        With objRegex
            .Global = True
            .ignorecase = True
            .MultiLine = True
            '.Pattern = "(\n)To:.*<(.+)>"
 
            '.Pattern = "\nTo:.([a-z0-9][a-z0-9-.]{0,32}[a-z0-9]\@[a-z0-9][a-z0-9-]{0,32}[a-z0-9](?:\.[a-z]{2,5}){1,2})\b"
            .Pattern = Patterns(j)
            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
                        GetToFromHeader = objRegM(0).submatches(i)
                        Exit Function
                    End If
                Next i
            Else
                GetToFromHeader = "No match"
            End If
        End With
    Next j
End Function

Pour changer le compte d'envoi à mettre dans ThisOutlookSession

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_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OLiv-
' Date      : 9/2/2018
' Purpose   :envoi en changeant de compte
'---------------------------------------------------------------------------------------
'
 
    ' on verifie que c'est un mail
    If Not Item.Class = olMail Then exit sub
        Dim msg As Object, Msg_to As String
    Set msg = FindParentMessage(Application.ActiveInspector.CurrentItem)
    If Not msg Is Nothing Then
        Msg_to = GetToFromHeader(msg)
        If Application.Session.Accounts.Item(1).displayName <> Msg_to and Msg_to <>"No match" Then
            SendUsingAccount Item, Msg_to
        End If
    End If
End sub
 
 
Sub SendUsingAccount(oMail, Adresse)
    Dim oAccount As Outlook.Account
    Set oAccount = Application.Session.Accounts(Adresse)
    oMail.SendUsingAccount = oAccount
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
Function FindParentMessage(msg As Outlook.MailItem) _
           As Outlook.MailItem
'http://www.outlookcode.com/codedetail.aspx?id=1714
    Dim strFind As String
    Dim strIndex As String
    Dim fld As Outlook.MAPIFolder
    Dim itms As Outlook.Items
    Dim itm As Outlook.MailItem
    On Error Resume Next
    strIndex = Left(msg.ConversationIndex, _
                    Len(msg.ConversationIndex) - 10)
    Set fld = Application.Session.GetDefaultFolder(olFolderInbox)
    strFind = "[ConversationTopic] = " & _
              Chr(34) & msg.ConversationTopic & Chr(34)
    Set itms = fld.Items.Restrict(strFind)
    Debug.Print itms.count
    For Each itm In itms
        If itm.ConversationIndex = strIndex Then
            Debug.Print itm.To
            Set FindParentMessage = itm
            Exit For
        End If
    Next
    Set fld = Nothing
    Set itms = Nothing
    Set itm = Nothing
End Function

la difficulté c'est de faire la liaison entre l'info du mail RECU et l'envoi de la réponse.

edit : voilà qui devrait fonctionner

[ekodante]

Bonjour,

D'avance merci pour la réponse,
Je n'ai pas eu le temps de tester avant.

Je prends donc le temps de répondre

J'ai un message d'erreur lorsque j'envoie un message qui est le suivant :

https://ibb.co/j237TS

merci pour tout en tout cas

[Oliv-]

Bonjour,
As tu bien copié la fonction FindParentMessage dans un module ?

[ekodante]

Et bien du coup, j'ai mis comme tu a mentionné,
Application_ItemSend et FindParentMessage dans le ThisOutlookSession au départ,
la je viens de faire différents test et rien n’aboutis malheureusement :/

actuellement j'ai
Application_ItemSend dans le outlooksession et
FindParentMessage dans un module.

[Oliv-]

Tu peux tout mettre dans ThisOUtlookSession.

efface tout et recommence.