Extrair eMails



Consegue extrair um endereço de eMail de uma linha onde estejam contidos outros dados?

Veja o exemplo: 

André Luiz Bernardes <bernardess@gmail.com>

Utilize a função ExtractEmailAddress para extrair somente o endereço do e-mail.

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


Tags: VBA, Tips, UDF, e-mail, eMail,




Nenhum comentário:

Postar um comentário

diHITT - Notícias