Updated email validation

This validation example has been updated to reflect the possibility of up to
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