by Joe Hunter
17. September 2010 09:24
Nice little function for validating email addresses in VB6 by Brad Murray
Reference: http://www.freevbcode.com/ShowCode.Asp?ID=201
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