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

[VB]
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
[/VB]

1 Star2 Stars3 Stars4 Stars5 Stars (No Ratings Yet)
Cargando…

Deja un comentario