Vérifier l'intégrité d'une adresse mail

[chemouz]

Bonsoir.

J'ai une Macro Outlook qui s'exécute à chaque réception d'un mail. Celle ci analyse l'objet et en fonction de celui ci transfère le mail puis le déplace dans le dossier GOOD si l'adresse est bonne sinon il le déplace simplement dans le dossier BAD.

J'aimerais vérifier l'intégrité d'une adresse mail c.a.d

Jamais deux . successifs
- 1 caractère alphabétique
- de 0 à n caractères alphanumériques ou - ou _ ou .
- un seul @
- de 0 à n caractères alphanumériques ou - ou .
- un groupe de caractères dans les tld connu


J'ai pour l'instant utilisé une macro trouvé sur le net sans trop chercher à comprendre Le problème c'est que dès que dès que l'adresse mail est en adresse@domaine (i.e sans le tld .fr ou .com ...) cela plante toute la macro.

Bon en regex ça serait le rêve bien m'enfin bon ...

Code :

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
121
122
123
124
125
126
127
128
129
130
131
132
133
 
'Macro a enregistrer dans ThisOutlookSession
Private Sub Application_NewMail()
    SortMail
End Sub
 
Sub SortMail()
    On Error GoTo SortMail_err
 
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Logfilepath As String
    Dim Recipient As String
    Dim Good As MAPIFolder
    Dim Bad As MAPIFolder
    Dim i As Integer
 
    Set ns = GetNamespace("MAPI")
 
    ' Variable du fichier de log, pour l'instant non utilisée
 
    'Le répertoire boîte de réception
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    'Les réservations traitées
    Set Good = Inbox.Folders("Good")
    'Les mails qui ne sont pas des réservations
    Set Bad = Inbox.Folders("Bad")
 
    'Si la macro est lancée à la main
    If Inbox.Items.Count = 0 Then
        MsgBox "Il n'y a pas de message dans la boîte de réception", vbInformation
        Exit Sub
    End If
 
    i = 0
 
    'On boucle sur les mails
    For Each Item In Inbox.Items
         'On récupère l'addresse mail dans Recipient
         Subject = Split(Item.Subject, ";")
         Recipient = Subject(0)
 
    'On vérifie l'adresse mail
   If ValidEmail(Recipient) Then
        If TypeName(Item) = "MailItem" Then
            'On créer le mail a rediriger
            Set myForward = Item.Forward
            myForward.Recipients.Add Recipient
            myForward.Send
            Item.Move Good
        End If
    Else
            Item.Move Bad
    End If
 
    Next Item
 
SortMail_exit:
        Set Item = Nothing
        Set ns = Nothing
        Exit Sub
 
SortMail_err:
        MsgBox "Une erreur est survenue" _
        & vbCrLf & "Nom de la macro: SortMail" _
        & vbCrLf & "Erreur n°: " & Err.Number _
        & vbCrLf & "Description de l'erreur: " & Err.Description _
        , vbCritical, "Erreur!"
        Resume SortMail_exit
 
End Sub
 
Function ValidEmail(ByVal strCheck As String) As Boolean
 
Dim bCK As Boolean
Dim strDomainType As String
Dim strDomainName As String
Const sInvalidChars As String = "!#$%^&*()=+{}[]|\;:'/?>,< "
Dim i As Integer
 
bCK = Not InStr(1, strCheck, Chr(34)) > 0 'Check to see if there is a double quote
If Not bCK Then GoTo ExitFunction
 
bCK = Not InStr(1, strCheck, "..") > 0 'Check to see if there are consecutive dots
If Not bCK Then GoTo ExitFunction
 
' Check for invalid characters.
If Len(strCheck) > Len(sInvalidChars) Then
    For i = 1 To Len(sInvalidChars)
        If InStr(strCheck, Mid(sInvalidChars, i, 1)) > 0 Then
            bCK = False
            GoTo ExitFunction
        End If
    Next
Else
    For i = 1 To Len(strCheck)
        If InStr(sInvalidChars, Mid(strCheck, i, 1)) > 0 Then
            bCK = False
            GoTo ExitFunction
        End If
    Next
End If
 
If InStr(1, strCheck, "@") > 1 Then 'Check for an @ symbol
    bCK = Len(Left(strCheck, InStr(1, strCheck, "@") - 1)) > 0
Else
    bCK = False
End If
If Not bCK Then GoTo ExitFunction
 
strCheck = Right(strCheck, Len(strCheck) - InStr(1, strCheck, "@"))
bCK = Not InStr(1, strCheck, "@") > 0 'Check to see if there are too many @'s
If Not bCK Then GoTo ExitFunction
 
strDomainType = Right(strCheck, Len(strCheck) - InStr(1, strCheck, "."))
bCK = Len(strDomainType) > 0 And InStr(1, strCheck, ".") < Len(strCheck)
If Not bCK Then GoTo ExitFunction
 
strCheck = Left(strCheck, Len(strCheck) - Len(strDomainType) - 1)
Do Until InStr(1, strCheck, ".") <= 1
    If Len(strCheck) >= InStr(1, strCheck, ".") Then
        strCheck = Left(strCheck, Len(strCheck) - (InStr(1, strCheck, ".") - 1))
    Else
        bCK = False
        GoTo ExitFunction
    End If
Loop
If strCheck = "." Or Len(strCheck) = 0 Then bCK = False
 
ExitFunction:
ValidEmail = bCK
End Function

Merci d'avance

[cavo789]

Bonjour

Il existe des expressions régulières qui devraient faire cela à merveille.

J'ai lancé une petite recherche sur Google avec ces termes "regular expression email validation" et j'obtiens un très grand nombre de code dont voici le premier lien : http://www.codetoad.com/asp_email_reg_exp.asp

A toi d'essayer...