✔ Programação GLOBAL®: Extrair eMails

Function ExtractEmailAddress(s As String) As String

' Author: Date: Contact:

' André Bernardes 11/08/2008 09:01 bernardess@gmail.com

' Extrai apenas o e-mail de uma célula.

Dim AtSignLocation As Long

Dim i As Long

Dim TempStr As String

Const CharList As String = "[A-Za-z0-9._-]"

'Localizando a @.

Let AtSignLocation = InStr(s, "@")

If AtSignLocation = 0 Then

Let ExtractEmailAddress = "" 'not found

Else

Let TempStr = ""

'Parte do e-mail antes da @.

For i = AtSignLocation - 1 To 1 Step -1

If Mid(s, i, 1) Like CharList Then

Let TempStr = Mid(s, i, 1) & TempStr

Else

Exit For

End If

Next i

If TempStr = "" Then Exit Function

'Parte do e-mail depois da @.

Let TempStr = TempStr & "@"

For i = AtSignLocation + 1 To Len(s)

If Mid(s, i, 1) Like CharList Then

Let TempStr = TempStr & Mid(s, i, 1)

Else

Exit For

End If

Next i

End If

'Remove trailing period if it exists

If Right(TempStr, 1) = "." Then _

Let TempStr = Left(TempStr, Len(TempStr) - 1)

Let ExtractEmailAddress = TempStr

End Function