vérifier existence adresse epéditeur

**phapha89** · 10/06/2015, 18h28

Bonjour, suite à l'aide d'Oliv, que je remercie beaucoup, je cherche désormais comment vérifier la validité d'une adresse mail en VBA, je veux dire vérifier si elle existe, merci d'avance !

**Oliv-** · 11/06/2015, 21h55

Bonsoir,
Tu peux tester comme cela

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Function verif_recipient(adresse As String) As Boolean
    Dim email As Outlook.MailItem
    Set email = CreateItem(olMailItem)
    Dim recip As recipient
    Set recip = email.Recipients.add(adresse)
    recip.Delete
    verif_recipient = recip.Resolve
    email.Close olDiscard
End Function
 
 
Sub test()
MsgBox verif_recipient("toto@titi.fr")
End Sub

**phapha89** · 18/06/2015, 19h02

Bonsoir Oliv, comment dois-je intégrer le script dans le mien en tout début de procédure ?

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
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
 
 
Sub REGLE_JUNK_TEST(StrID As Outlook.MailItem)
'---------------------------------------------------------------------------------------
' Procedure : REGLE_JUNK_TEST
' Author    : OCTU
' Date      : 03/06/2015
' Purpose   : Place l'expéditeur dans les expediteurs approuvé si le corps du Mail contient un code sinon envoi une réponse
'---------------------------------------------------------------------------------------
'
    Dim Mymail As Outlook.MailItem
    Dim Expediteur
    If Not StrID.Class = olMail Then Exit Sub
    Set Mymail = StrID
 
    Expediteur = Get_sender_SMTP(StrID)
 
    ' On vérifie si l'expéditeur est déjà approuvé :
 
    Set RDOSession = CreateObject("Redemption.RDOSession")
    RDOSession.MAPIOBJECT = Application.Session.MAPIOBJECT
    Set JunkOptions = RDOSession.JunkEmailOptions
 
    For Each Address In JunkOptions.TrustedSenders
        If Address = Expediteur Then
            'expéditeur approuvé
'            MsgBox Expediteur & " est accepté"
            Exit Sub
        End If
    Next
 
    ' On supprime le mail si l'expéditeur est dans la liste d'expéditeurs bloqués
    For Each Address In JunkOptions.BlockedSenders
        If Address = Expediteur Then
            'expéditeur bloqué
'            MsgBox Expediteur & " est bloqué"
            Mymail.Delete
            Exit Sub
        End If
    Next
 
 
    If InStr(1, Mymail.HTMLBody, "#code#", vbTextCompare) > 0 Then
        'ajout de l'expéditeur dans les expediteurs approuves
        Set RDOSession = CreateObject("Redemption.RDOSession")
        RDOSession.MAPIOBJECT = Application.Session.MAPIOBJECT
        Set JunkOptions = RDOSession.JunkEmailOptions
        JunkOptions.TrustedSenders.Add Expediteur
        JunkOptions.Save
 
'    ElseIf
 
    Else
        'envoi d'un mail Type
        Dim LaReponse As MailItem
        Set LaReponse = Mymail.Reply
 
        'LaReponse.subject = "ici on modifie le sujet"
 
 
        'Si on veux supprimer la signature
'        Select Case LaReponse.BodyFormat
'        Case olFormatHTML
'            LaReponse.HTMLBody = Mymail.HTMLBody
'        Case Else
'            LaReponse.Body = Mymail.Body
'        End Select
 
 
        MonTexteEnPlus = "<BR> </BR>" & "<BR> </BR>" & "Bonjour, vous venez de m'adresser un mail, or, vous ne figurez pas encore parmi mes expéditeurs approuvés." _
            & " Pour que je puisses dorénavant lire vos messages, merci de répondre en indiquant ce que vous lisez dans l'image ci-dessous !" _
            & " Cette procédure est à faire une seule fois, " _
            & "et sert à lutter contre les messages publicitaires !"
 
 
        Select Case LaReponse.BodyFormat
            'ici on vérifie le format du message HTML OU BRUT ...
 
        Case olFormatHTML:
 
            OuCommenceAdresse = InStr(1, LaReponse.HTMLBody, "<BODY", vbTextCompare)
            If OuCommenceAdresse > 0 Then
                fin = InStr(OuCommenceAdresse + 5, LaReponse.HTMLBody, ">") + 1
                BaliseBody = Mid(LaReponse.HTMLBody, OuCommenceAdresse, fin - OuCommenceAdresse)
 
                LaReponse.HTMLBody = Replace(LaReponse.HTMLBody, BaliseBody, BaliseBody & "<font style='font-family: Verdana ;font-size: 12pt ;color:red;font-style: italic;'>" & MonTexteEnPlus & "</font><BR>" _
                                                                           & "<font style='font-family: Verdana ;font-size: 12pt ;color:black;font-style: italic;'>" & "<BR> </BR>" & "<img src='c:\capcha.jpg' >" & String(NbTiret, "-") & "</font><BR><BR>", 1, 1, vbTextCompare)
            Else: LaReponse.HTMLBody = "<font style='font-family: Tahoma ;font-size: 12pt ;color:red;font-style: italic;'>" & liste & _
                                       "</font><BR>" & "<font style='font-family: Verdana ;font-size: 12pt ;color:black;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>" & LaReponse.HTMLBody & MonTexteEnPlus & "<img src='c:\capcha.jpg' >"
 
            End If
        Case Else
            'LaReponse.Body = Replace(MonTexteEnPlus, "<br>", vbCr) & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & LaReponse.Body & "<img src='http://clv-couverture.com/capcha.jpg' >"
            LaReponse.Body = "<font style='font-family: Tahoma ;font-size: 12pt ;color:red;font-style: italic;'>" & liste & _
                                       "</font><BR>" & "<font style='font-family: Verdana ;font-size: 12pt ;color:black;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>" & LaReponse.HTMLBody & MonTexteEnPlus & "<img src='c:\capcha.jpg' >"
 
        End Select
 
       'commentez/Décommentez 1 ou 2 ( 1 ouvre le message a envoyé, 2 envoi direct )
         'LaReponse.Display      '1
            LaReponse.Send     '2
 
         ' On supprime le mail
 
     Mymail.Delete
 
    End If
    Set Mymail = Nothing
    Set olNS = Nothing
fin:
End Sub
 
Private Function Get_sender_SMTP(OITEM As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = OITEM.Sender.GetExchangeUser
 
    Get_sender_SMTP = oEU.PrimarySmtpAddress
    If Get_sender_SMTP = "" Then Get_sender_SMTP = OITEM.SenderEmailAddress
End Function

**Oliv-** · 18/06/2015, 21h41

Bonsoir,

Quel est le but de cette vérification ?

**phapha89** · 19/06/2015, 06h13

Bonjour Oliv, le but est de ne pas envoyer le mail avec demande de code à un destinataire dont l'adresse mail n'existe pas !

J'ai du mal à m'exprimer, mais en gros, aujourd'hui les scripts que tu m'as donné font çà :

1 - Si l'adresse EXP est dans la liste EXP APPROUVES alors le mail arrive

2 - supprime le mail si l'expéditeur est dans la liste d'expéditeurs bloqués

3 - Si le code demandé est dans le corp du message, on ajoute l'expéditeur dans EXP APPROUVES

4 - Sinon on envoi un mail de confirmation de code

------> Le problème c'est que quand arrive un mail de pub, donc adresse inconnu, le script envoi le mail de confirmation, en retour, j'ai une réponse du genre :

Certains des destinataires ou tous les destinataires n'ont pas reçu votre message

et donc le script renvoie encore le mail de confirmation, d'où ma vérification de mail pour ne pas envoyer si l'adresse ne répond pas ou n'existe pas !

J'espère être clair, merci d'avance !

**Oliv-** · 19/06/2015, 09h26

Bonjour,
Ok je comprends mieux, mais ce genre de fonction, ne sert qu'à vérifier la COHERENCE d'une adresse Email, (xxx.@.xxx).

Tu ne peux pas vérifier l'existence réelle, sans envoyer un Email.

Ce que tu dois pouvoir faire c'est créer une REGLE qui va supprimer le Mail "delivery report"

vérifier existence adresse epéditeur

VBA Outlook

Discussions similaires

Partager

Partager