✔ Programação GLOBAL®: VBA Tips - Validando endereços de eMail

| Blog Office VBA | Blog Excel | Blog Access |

Imagine que você tenha um banco de dados enorme, cheio de endereços de email, ou que você tenha copiado uma página da web que tinha endereços de correio eletrônico com textos desnecessários e você queira destacar as ocorrências inválidas ou extrair os endereços válidos de e-mail deles.

Function CheckEmail(ByVal EmailAddress As String)

Dim sArray As Variant, sItem As Variant

Dim n As Long, c As String

'Find the number of @, it should be exactly one.

n = Len(EmailAddress) - Len(Application.Substitute(EmailAddress, "@", ""))

If n <> 1 Then CheckEmail = False: Exit Function

ReDim sArray (1 To 2)

sArray (1) = Left(EmailAddress, InStr(1, EmailAddress, "@", 1) - 1)

sArray (2) = Application.Substitute(Right(EmailAddress, Len(EmailAddress ) - Len(sArray(1))), "@", "")

For Each sItem In sArray

'There should be atleast one character before @.

If Len(sItem) <= 0 Then CheckEmail = False: Exit Function

For n = 1 To Len(sItem)

c = LCase(Mid(sItem, n, 1))

If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then CheckEmail = False: Exit Function

Next

'Extreme characters must not be period or dot (.)

If Left(sItem, 1) = "." Or Right(sItem, 1) = "." Then CheckEmail = False: Exit Function

Next

'There must be atleast one period or dot after @

If InStr(sArray(2), ".") <= 0 Then CheckEmail = False: Exit Function

'After the last dot or period, there must be either exactly 2 or 3 characters.

n = Len(sArray(2)) - InStrRev(sArray(2), ".")

If n <> 2 And n <> 3 Then CheckEmail = False: Exit Function

'It must not contain 2 or more consecutive periods or dots.

If InStr(EmailAddress, "..") > 0 Then CheckEmail = False: Exit Function

CheckEmail = True

End Function