30 Ene Como extraer un email de un texto en Visual Basic

Esta es una función que suelo utilizar para extraer emails de texto. Es la versión simplificada para encontrar un solo email ya que con una modificación en el Gosub puede capturar un número indeterminado de emails y almacenarlos en una colección de objetos.

La función también sirve de ejemplo para la utilización de varias sentencias de manejo de strings en Visual Basic: Instr, Len, Mid y Asc

Public Function CapturarEmailTexto(Texto) As String
    Dim indPos As Long
    Dim indDesde As Long
    Dim indHasta As Long
    Dim strEmail As String
    Dim strInt   As String
    On Error GoTo ErrorSub
    CapturarEmailTexto = ""
    strEmail = ""
    If InStr(1, Texto, "@") = 0 Then Exit Function
    For indPos = 1 To Len(Texto)
        If Mid(Texto, indPos, 1) = "@" Then
            GoSub Captura
            Exit For
        End If
    Next
    CapturarEmailTexto = strEmail
    Exit Function
Captura:
    indDesde = 0
    indHasta = 0
' Buscar Inicio de Email
    For indDesde = indPos - 1 To 0 Step -1
        If indDesde = 0 Then Exit For
        strInt = Mid(Texto, indDesde, 1)
        If strInt = " " Then Exit For
        If strInt = ":" Then Exit For
        If strInt = "(" Then Exit For
        If strInt = ")" Then Exit For
        If strInt = "[" Then Exit For
        If strInt = "]" Then Exit For
        If strInt = "<" Then Exit For
        If strInt = ">" Then Exit For
        If strInt = """" Then Exit For
        If strInt = "'" Then Exit For
        If Asc(strInt) = 13 Then Exit For ' Control de Return
        If Asc(strInt) = 10 Then Exit For ' Control de Return
    Next
' Buscar Final de Email
    For indHasta = indPos + 1 To Len(Texto)
        strInt = Mid(Texto, indHasta, 1)
        If strInt = " " Then Exit For
        If strInt = ":" Then Exit For
        If strInt = "(" Then Exit For
        If strInt = ")" Then Exit For
        If strInt = "[" Then Exit For
        If strInt = "]" Then Exit For
        If strInt = "<" Then Exit For
        If strInt = ">" Then Exit For
        If strInt = """" Then Exit For
        If strInt = "'" Then Exit For
        If Asc(strInt) = 13 Then Exit For ' Control de Return
        If Asc(strInt) = 10 Then Exit For ' Control de Return
    Next
' Determinar Mail
    strEmail = Mid(Texto, indDesde + 1, indHasta - indDesde - 1)
' Eliminar Caracteres Finales incorrectos
    If Right(strEmail, 1) = "." Then strEmail = Mid(strEmail, 1, Len(strEmail) - 1)
    If Right(strEmail, 1) = "," Then strEmail = Mid(strEmail, 1, Len(strEmail) - 1)
    Return
ErrorSub:
    MsgBox Err.Number & ": " & Err.Description
End Function

(1 votes, average: 5,00 out of 5)

Cargando…