Si gestionas una lista de suscripción por correo electrónico, es posible que recibas direcciones de email no válidas, como direcciones con un espacio en blanco delante de @. La siguiente función puede comprobar las direcciones de correo electrónico y confirmar que se trata de direcciones válidas.

IsEmailValid(StrEmail)

El argumento es:

StrEmail: Una dirección de correo electrónico.

Function IsEmailValid(strEmail As String) As Boolean
  Dim strArray As Variant
  Dim strItem As Variant
  Dim i As Long
  Dim c As String
  Dim blnIsItValid As Boolean
  blnIsItValid = True
  'Cuenta la @ en la cadena
  i = Len(strEmail) - Len(Application.Substitute(strEmail, "@", ""))
  'si hay más de una @, dirección no válida
  If i <> 1 Then IsEmailValid = False: Exit Function
    ReDim strArray(1 To 2)
    'las siguientes dos líneas sitúan el texto a la izquierda y derecha
    'de la @ en sus propias variables
    strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)
    strArray(2) = Application.Substitute(Right(strEmail, Len(strEmail) - _
    Len(strArray(1))), "@", "")
    For Each strItem In strArray
      'comprobar que hay algo en la variable
      'si no hay nada entonces falta parte de la dirección
      If Len(strItem) <= 0 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
      End If
      'comprobar solamente caracteres válidos en la dirección
      For i = 1 To Len(strItem)
        'poner en minúsculas todas las letras para una mejor comprobación
        c = LCase(Mid(strItem, i, 1))
        If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 _
          And Not IsNumeric(c) Then
          blnIsItValid = False
          IsEmailValid = blnIsItValid
          Exit Function
        End If
      Next i
      'comprobar que el primer carácter a la izquierda y derecha no son puntos
      If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
      End If
    Next strItem

    'comprobar que hay un punto en la mitad derecha de la dirección
    If InStr(strArray(2), ".") <= 0 Then
      blnIsItValid = False
      IsEmailValid = blnIsItValid
      Exit Function
    End If
    i = Len(strArray(2)) - InStrRev(strArray(2), ".") 'colocar el punto
    'comprobar que el número de letras corresponden a una extensión de dominio válida
    If i <> 2 And i <> 3 And i <> 4 Then
      blnIsItValid = False
      IsEmailValid = blnIsItValid
      Exit Function
    End If
    'comprobar que no hay dos puntos juntos en la dirección
    If InStr(strEmail, "..") > 0 Then
      blnIsItValid = False
      IsEmailValid = blnIsItValid
      Exit Function
    End If

    IsEmailValid = blnIsItValid
End Function

Technorati Tags: Funciones