Thursday, July 23, 2009

Check and e-mail address for validity

Code following to know the validity of e-mail:

Function IsValidEmail(sEMail As String) As Boolean
' original by Brad Murray
' optimized by Rob Hofker, email: rob@eurocamp.nl,
'23 august 2000

Dim sInvalidChars As String
Dim bTemp As Boolean
Dim i As Integer
Dim sTemp As String

' Disallowed characters
sInvalidChars = "!#$%^&*()=+{}[]|\;:'/?>,< "

' Check that there is at least one '@'
bTemp = InStr(sEMail, "@") <= 0
If bTemp Then GoTo exit_function

' Check that there is at least one '.'
bTemp = InStr(sEMail, ".") <= 0
If bTemp Then GoTo exit_function

' and that the length is at least six (a@a.ca)
bTemp = Len(sEMail) < 6
If bTemp Then GoTo exit_function

' Check that there is only one '@'
i = InStr(sEMail, "@")
sTemp = Mid(sEMail, i + 1)
bTemp = InStr(sTemp, "@") > 0

If bTemp Then GoTo exit_function
'extra checks
' AFTER '@' space is not allowed
bTemp = InStr(sTemp, " ") > 0
If bTemp Then GoTo exit_function

' Check that there is one dot AFTER '@'
bTemp = InStr(sTemp, ".") = 0
If bTemp Then GoTo exit_function

' Check if there's a quote (")
bTemp = InStr(sEMail, Chr(34)) > 0
If bTemp Then GoTo exit_function

' Check if there's any other disallowed chars
' optimize a little if sEmail longer than sInvalidChars
' check the other way around
If Len(sEMail) > Len(sInvalidChars) Then
For i = 1 To Len(sInvalidChars)
If InStr(sEMail, Mid(sInvalidChars, i, 1)) > 0 _
Then bTemp = True
If bTemp Then Exit For
Next
Else
For i = 1 To Len(sEMail)
If InStr(sInvalidChars, Mid(sEMail, i, 1)) > 0 _
Then bTemp = True
If bTemp Then Exit For
Next
End If
If bTemp Then GoTo exit_function

' extra check
' no two consecutive dots
bTemp = InStr(sEMail, "..") > 0
If bTemp Then GoTo exit_function

exit_function:
' if any of the above are true, invalid e-mail
IsValidEmail = Not bTemp

End Function


No comments:

Post a Comment