02-08-2007, 08:02 PM
Sorry, slightly old topic, but heres my verification code that works a bit better:
Code:
Public Function ValidateEmail(ByRef sEmail As String) As Boolean
Dim bValid As Boolean ' Is email valid?
Dim bFlag As Boolean ' Multipurpose boolean value
Dim vntEmail As Variant ' Splitted Email
Dim vntDomain As Variant ' Splitted Domain
Dim vntValidDomainExt As Variant ' Valid domain extensions
Dim lCount As Long ' Loop variable
Dim lChars As Long ' Second loop variable
' Validates a email of form "a.bc_123@server.ext"
' Insert valid domain extensions in variable
vntValidDomainExt = Array("no", "com", "edu", "gov", "int", "mil", "net", "org", "info", "biz", "pro", "name", "coop", "museum", _
"aero", "af", "al", "dz", "as", "ad", "ao", "ai", "aq", "ag", "ar", "am", "aw", "ac", "au", "at", "az", _
"bs", "bh", "bd", "bb", "By", "be", "bz", "bj", "bm", "bt", "bo", "ba", "bw", "bv", "br", "io", "bn", _
"bg", "bf", "bi", "kh", "cm", "ca", "cv", "ky", "cf", "td", "cs", "cl", "cn", "cx", "cc", "co", "km", _
"cg", "ck", "cr", "ci", "hr", "cu", "cy", "cz", "dk", "dj", "dm", "do", "tp", "ec", "eg", "sv", "gq", _
"er", "ee", "et", "fk", "fo", "fj", "fi", "fr", "gf", "pf", "tf", "ga", "gm", "ge", "de", "gh", "gi", _
"gr", "gl", "gd", "gp", "gu", "gt", "gg", "gn", "gw", "gy", "ht", "hm", "va", "hn", "hk", "hu", "is", _
"In", "id", "ir", "iq", "ie", "im", "il", "it", "jm", "jp", "je", "jo", "kz", "ke", "ki", "kp", "kr", _
"kw", "kg", "la", "lv", "lb", "ls", "lr", "ly", "li", "lt", "lu", "mo", "mk", "mg", "mw", "my", "mv", _
"ml", "mt", "mh", "mq", "mr", "mu", "yt", "mx", "fm", "md", "mc", "mn", "ms", "ma", "mz", "mm", "na", _
"nr", "np", "nl", "an", "nc", "nz", "ni", "ne", "ng", "nu", "nf", "mp", "no", "om", "pk", "pw", "ps", _
"pa", "pg", "py", "pe", "ph", "pn", "pl", "pt", "pr", "qa", "re", "ro", "ru", "rw", "kn", "lc", "vc", _
"ws", "sm", "st", "sa", "sn", "sc", "sl", "sg", "sk", "si", "sb", "so", "za", "gs", "es", "lk", "sh", _
"pm", "sd", "sr", "sj", "sz", "se", "ch", "sy", "tw", "tj", "tz", "th", "tg", "tk", "to", "tt", "tn", _
"tr", "tm", "tc", "tv", "ug", "ua", "ae", "gb", "uk", "us", "um", "uy", "su", "uz", "vu", "ve", "vn", _
"vg", "vi", "wf", "eh", "ye", "yu", "cd", "zm", "zr", "zw")
' Emails are normally composed of only lower-case characters
' so lower-case the email and since the parameter is ByRef, the
' email will be lower-cased back there.
sEmail = LCase$(sEmail)
' If sEmail contains "@"
If InStr(sEmail, "@") Then
' Split email on "@"
vntEmail = Split(sEmail, "@")
' Asuure only 1 "@"
If UBound(vntEmail) = 1 Then
' Starts with alphanumeric character
If Left$(vntEmail(0), 1) Like "[a-z]" Or Left$(vntEmail(0), 1) Like "[0-9]" Then
bFlag = True
' Assure all other characters are alphanumeric or "." or "_"
For lCount = 2 To Len(vntEmail(0))
If Not (Mid$(vntEmail(0), lCount, 1) Like "[a-z]" Or Mid$(vntEmail(0), lCount, 1) Like "[0-9]" Or Mid$(vntEmail(0), lCount, 1) = "." Or Mid$(vntEmail(0), lCount, 1) Like "_") Then
bFlag = False
End If
Next lCount
If bFlag Then
' If domain part contains "."
If InStr(vntEmail(1), ".") Then
' Split domains on "."
vntDomain = Split(vntEmail(1), ".")
bFlag = True
' Assure all domains characters are alphanumeric and domain length is over 1 (>= 2)
For lCount = LBound(vntDomain) To UBound(vntDomain)
If Len(vntDomain(lCount)) < 2 Then
bFlag = False
End If
For lChars = 1 To Len(vntDomain(lCount))
If Not (Mid$(vntDomain(lCount), lChars, 1) Like "[a-z]" Or Mid$(vntDomain(lCount), lChars, 1) Like "[0-9]") Then
bFlag = False
End If
If Not bFlag Then
Exit For
End If
Next lChars
If Not bFlag Then
Exit For
End If
Next lCount
If bFlag Then
bFlag = False
' Check if email domain extension is valid
For lCount = LBound(vntValidDomainExt) To UBound(vntValidDomainExt)
If vntDomain(UBound(vntDomain)) = vntValidDomainExt(lCount) Then
bFlag = True
Exit For
End If
Next lCount
If bFlag Then
' If email has passed through all this, it's valid
bValid = True
End If
End If
End If
End If
End If
End If
End If
ValidateEmail = bValid
End Function