- Function EmailValide(sAdresse) As Boolean
- Const Accents = "àáâãäåèéêëìíîïðñòóôõöùúûüýÿ"
- Const CarInterdits = ",;#`'/*+:\&<>~{}=)([]|?§"
-
- Dim TestAdrMail As Boolean, TestAccents, TestCarInterdits As Boolean
- Dim i As Integer
- Dim pos_point, pos_point2, pos_arobase, pos_arobase2 As Integer
-
- If Len(sAdresse) = 0 Or IsNull(sAdresse) Then
- TestAdrMail = True
- Else
- pos_arobase = InStr(1, sAdresse, "@")
- 'Vérifie qu'il n'y a pas plusieurs @ dans l'adresse mail
- pos_arobase2 = InStr(1, Right(sAdresse, Len(sAdresse) - pos_arobase), "@")
- 'Position du . après l'@
- pos_point = InStr(pos_arobase + 1, sAdresse, ".")
- 'Position du . avant l'@
- pos_point2 = InStr(pos_arobase - 1, sAdresse, ".")
-
- 'Critères de validité :
- '@ pas en première position
- 'Pas de . en 1ère position
- 'Pas de @.
- 'Pas de .@
- 'Au moins 2 caractères dans l'adresse
- 'Pas d'@ après le 1er @
- If (pos_arobase > 1 And pos_point > 1 And Len(sAdresse) > 2 And pos_point - pos_arobase > 1 And pos_arobase - pos_point2 > 1 And pos_arobase2 = 0) Then
- TestAdrMail = True
- Else
- TestAdrMail = False
- End If
- End If
-
- 'Vérifie qu'il n'y a pas de caractères accentués dans l'adresse mail
- TestAccents = True
-
- For i = 1 To Len(sAdresse)
- If InStr(1, Accents, LCase(Mid(sAdresse, i, 1))) > 0 Then
- TestAccents = False
- Exit For
- End If
- Next
-
- 'Vérifie qu'il n'y a pas de caractères exclus dans l'adresse mail
- TestCarInterdits = True
-
- For i = 1 To Len(sAdresse)
- If InStr(1, CarInterdits, LCase(Mid(sAdresse, i, 1))) > 0 Then
- TestCarInterdits = False
- Exit For
- End If
- Next
-
- EmailValide = TestAdrMail And TestAccents And TestCarInterdits And ChercheEspace(sAdresse) = False
- End Function
-
- Function ChercheEspace(ByVal LETEXTE As String)
- Const strSpacer = " "
- Dim TestEspace As Boolean
- Dim i As Integer
-
- TestEspace = False
-
- For i = 1 To Len(LETEXTE)
- If InStr(1, strSpacer, LCase(Mid(LETEXTE, i, 1))) > 0 Then
- TestEspace = True
- Exit For
- End If
- Next
-
- ChercheEspace = TestEspace
- End Function
Function EmailValide(sAdresse) As Boolean
Const Accents = "àáâãäåèéêëìíîïðñòóôõöùúûüýÿ"
Const CarInterdits = ",;#`'/*+:\&<>~{}=)([]|?§"
Dim TestAdrMail As Boolean, TestAccents, TestCarInterdits As Boolean
Dim i As Integer
Dim pos_point, pos_point2, pos_arobase, pos_arobase2 As Integer
If Len(sAdresse) = 0 Or IsNull(sAdresse) Then
TestAdrMail = True
Else
pos_arobase = InStr(1, sAdresse, "@")
'Vérifie qu'il n'y a pas plusieurs @ dans l'adresse mail
pos_arobase2 = InStr(1, Right(sAdresse, Len(sAdresse) - pos_arobase), "@")
'Position du . après l'@
pos_point = InStr(pos_arobase + 1, sAdresse, ".")
'Position du . avant l'@
pos_point2 = InStr(pos_arobase - 1, sAdresse, ".")
'Critères de validité :
'@ pas en première position
'Pas de . en 1ère position
'Pas de @.
'Pas de .@
'Au moins 2 caractères dans l'adresse
'Pas d'@ après le 1er @
If (pos_arobase > 1 And pos_point > 1 And Len(sAdresse) > 2 And pos_point - pos_arobase > 1 And pos_arobase - pos_point2 > 1 And pos_arobase2 = 0) Then
TestAdrMail = True
Else
TestAdrMail = False
End If
End If
'Vérifie qu'il n'y a pas de caractères accentués dans l'adresse mail
TestAccents = True
For i = 1 To Len(sAdresse)
If InStr(1, Accents, LCase(Mid(sAdresse, i, 1))) > 0 Then
TestAccents = False
Exit For
End If
Next
'Vérifie qu'il n'y a pas de caractères exclus dans l'adresse mail
TestCarInterdits = True
For i = 1 To Len(sAdresse)
If InStr(1, CarInterdits, LCase(Mid(sAdresse, i, 1))) > 0 Then
TestCarInterdits = False
Exit For
End If
Next
EmailValide = TestAdrMail And TestAccents And TestCarInterdits And ChercheEspace(sAdresse) = False
End Function
Function ChercheEspace(ByVal LETEXTE As String)
Const strSpacer = " "
Dim TestEspace As Boolean
Dim i As Integer
TestEspace = False
For i = 1 To Len(LETEXTE)
If InStr(1, strSpacer, LCase(Mid(LETEXTE, i, 1))) > 0 Then
TestEspace = True
Exit For
End If
Next
ChercheEspace = TestEspace
End Function