245 known ISO country codes in addition to the regular extensions of email addresses.
Option Explicit
Public EMsg As String 'used to return potential error messages in the functions below
Public Function ValidateEmail(ByVal strEmail As String) As Boolean
Dim strTmp As String, n As Long, sEXT As String
EMsg = "" 'reset on open for good form
ValidateEmail = True 'Assume true on init
sEXT = strEmail
Do While InStr(1, sEXT, ".") <> 0
sEXT = Right(sEXT, Len(sEXT) - InStr(1, sEXT, "."))
Loop
If strEmail = "" Then
ValidateEmail = False
EMsg = EMsg & "<BR>You did not enter an email address!"
ElseIf InStr(1, strEmail, "@") = 0 Then
ValidateEmail = False
EMsg = EMsg & "<BR>Your email address does not contain an @ sign."
ElseIf InStr(1, strEmail, "@") = 1 Then
ValidateEmail = False
EMsg = EMsg & "<BR>Your @ sign can not be the first character in your email address!"
ElseIf InStr(1, strEmail, "@") = Len(strEmail) Then
ValidateEmail = False
EMsg = EMsg & "<BR>Your @sign can not be the last character in your email address!"
ElseIf EXTisOK(sEXT) = False Then
ValidateEmail = False
EMsg = EMsg & "<BR>Your email address is not carrying a valid ending!"
EMsg = EMsg & "<BR>It must be one of the following..."
EMsg = EMsg & "<BR>.com, .net, .gov, .org, .edu, .biz, .tv Or included country's assigned country code"
ElseIf Len(strEmail) < 6 Then
ValidateEmail = False
EMsg = EMsg & "<BR>Your email address is shorter than 6 characters which is impossible."
End If
strTmp = strEmail
Do While InStr(1, strTmp, "@") <> 0
n = 1
strTmp = Right(strTmp, Len(strTmp) - InStr(1, strTmp, "@"))
Loop
If n > 1 Then
ValidateEmail = False 'found more than one @ sign
EMsg = EMsg & "<BR>You have more than 1 @ sign in your email address"
End If
End Function
Public Function EXTisOK(ByVal sEXT As String) As Boolean
Dim EXT As String, X As Long
EXTisOK = False
If Left(sEXT, 1) <> "." Then sEXT = "." & sEXT
sEXT = UCase(sEXT) 'just to avoid errors
EXT = EXT & ".COM.EDU.GOV.NET.BIZ.ORG.TV"
EXT = EXT & ".AF.AL.DZ.As.AD.AO.AI.AQ.AG.AP.AR.AM.AW.AU.AT.AZ.BS.BH.BD.BB.BY"
EXT = EXT & ".BE.BZ.BJ.BM.BT.BO.BA.BW.BV.BR.IO.BN.BG.BF.MM.BI.KH.CM.CA.CV.KY"
EXT = EXT & ".CF.TD.CL.CN.CX.CC.CO.KM.CG.CD.CK.CR.CI.HR.CU.CY.CZ.DK.DJ.DM.DO"
EXT = EXT & ".TP.EC.EG.SV.GQ.ER.EE.ET.FK.FO.FJ.FI.CS.SU.FR.FX.GF.PF.TF.GA.GM.GE.DE"
EXT = EXT & ".GH.GI.GB.GR.GL.GD.GP.GU.GT.GN.GW.GY.HT.HM.HN.HK.HU.IS.IN.ID.IR.IQ"
EXT = EXT & ".IE.IL.IT.JM.JP.JO.KZ.KE.KI.KW.KG.LA.LV.LB.LS.LR.LY.LI.LT.LU.MO.MK.MG"
EXT = EXT & ".MW.MY.MV.ML.MT.MH.MQ.MR.MU.YT.MX.FM.MD.MC.MN.MS.MA.MZ.NA"
EXT = EXT & ".NR.NP.NL.AN.NT.NC.NZ.NI.NE.NG.NU.NF.KP.MP.NO.OM.PK.PW.PA.PG.PY"
EXT = EXT & ".PE.PH.PN.PL.PT.PR.QA.RE.RO.RU.RW.GS.SH.KN.LC.PM.ST.VC.SM.SA.SN.SC"
EXT = EXT & ".SL.SG.SK.SI.SB.SO.ZA.KR.ES.LK.SD.SR.SJ.SZ.SE.CH.SY.TJ.TW.TZ.TH.TG.TK"
EXT = EXT & ".TO.TT.TN.TR.TM.TC.TV.UG.UA.AE.UK.US.UY.UM.UZ.VU.VA.VE.VN.VG.VI"
EXT = EXT & ".WF.WS.EH.YE.YU.ZR.ZM.ZW"
EXT = UCase(EXT) 'just to avoid errors
If InStr(1, sEXT, EXT, vbBinaryCompare) <> 0 Then EXTisOK = True
End Function
Comments