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
No Comments