' la funcin retorna TRue o False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Validar_Email(eMail As String) As Boolean

   Dim strTmp As String
   Dim N As Long
   Dim sEXT As String
   
   MensajeError = ""
   Validar_Email = True
   
   sEXT = eMail
   
   Do While InStr(1, sEXT, ".") <> 0
      sEXT = Right(sEXT, Len(sEXT) - InStr(1, sEXT, "."))
   Loop
   
   If eMail = "" Then
      Validar_Email = False
      MensajeError = MensajeError & "No se indic ninguna direccin de " & _
                     "e-mail para verificar!" & vbNewLine
   ElseIf InStr(1, eMail, "@") = 0 Then
      Validar_Email = False
      MensajeError = MensajeError & "La direccin de e-mail no contiene el signo @" & vbNewLine
   ElseIf InStr(1, eMail, "@") = 1 Then
      Validar_Email = False
      MensajeError = MensajeError & "El @ No puede estar al principio" & vbNewLine
   ElseIf InStr(1, eMail, "@") = Len(eMail) Then
      Validar_Email = False
      MensajeError = MensajeError & "El @ no puede estar al final de la direccin" & vbNewLine
   ElseIf EXTisOK(sEXT) = False Then
      Validar_Email = False
      MensajeError = MensajeError & "La direccin no tiene un dominio vlido, "
      MensajeError = MensajeError & "por ejemplo : "
      MensajeError = MensajeError & ".com, .net, .gov, .org, .edu, .biz, .tv etc.. " & vbNewLine
   ElseIf Len(eMail) < 6 Then
      Validar_Email = False
      MensajeError = MensajeError & "La direccin no puede ser menor a 6 caracteres." & vbNewLine
   End If
   strTmp = eMail
   Do While InStr(1, strTmp, "@") <> 0
      N = 1
      strTmp = Right(strTmp, Len(strTmp) - InStr(1, strTmp, "@"))
   Loop
   If N > 1 Then
      Validar_Email = False
      MensajeError = MensajeError & "Solo puede haber un @ en la direccin de e-mail" & vbNewLine
   End If

    Dim Pos As Integer

    Pos = InStr(1, eMail, "@")

    If Mid(eMail, Pos + 1, 1) = "." Then
        Validar_Email = False
        MensajeError = MensajeError & "El punto no puede estar seguido del @" & vbNewLine
    End If

    If MensajeError <> "" Then
        MsgBox MensajeError, vbCritical, "Verificar Correo"
    End If

End Function


Public Function EXTisOK(ByVal sEXT As String) As Boolean

   Dim EXT As String
   Dim 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, EXT, sEXT, 0) <> 0 Then
       EXTisOK = True
   End If

End Function
