Veja se essa udf lhe atende
Se o email for invalido retorna Empty.
-> Sugestao de uso :
TextBox1.Text = EMAIL(Me.TextBox1.Text)
Cole em um modulo:
Option Explicit
Function EMAIL(eMail_Address As String) As String
' * ' Initialize
Const Test_Pattern As String = "^[w-.]+@([w-]+.)+[A-Za-z]{2,3}$"
On Error Resume Next
' * ' Define variables
Dim Counter As Long
Dim Email_Array As Variant
eMail_Address = LCase(Replace(Replace(eMail_Address, " ", vbNullString), ",", ";"))
For Counter = 1 To Len(eMail_Address)
If Left(eMail_Address, 1) = ";" Then eMail_Address = Mid(eMail_Address, 2)
If Right(eMail_Address, 1) = ";" Then eMail_Address = Left(eMail_Address, Len(eMail_Address) - 1)
Next
If Len(eMail_Address) < 6 Then eMail_Address = vbNullString
If eMail_Address = vbNullString Then GoTo EF:
' * ' Test if single email address is valid
Counter = 0
Counter = InStr(1, eMail_Address, ";")
If Counter < 1 Then
With CreateObject("VBScript.RegExp")
.Pattern = Test_Pattern
If .Test(eMail_Address) = False Then eMail_Address = vbNullString
End With
GoTo EF:
End If
' * ' Test if multiple email addresses are valid
Email_Array = Split(eMail_Address, ";")
eMail_Address = vbNullString
For Counter = LBound(Email_Array) To UBound(Email_Array)
With CreateObject("VBScript.RegExp")
.Pattern = Test_Pattern
If .Test(Email_Array(Counter)) = True Then eMail_Address = eMail_Address & Email_Array(Counter) & ";"
End With
Next
For Counter = 1 To Len(eMail_Address)
If Left(eMail_Address, 1) = ";" Then eMail_Address = Mid(eMail_Address, 2)
If Right(eMail_Address, 1) = ";" Then eMail_Address = Left(eMail_Address, Len(eMail_Address) - 1)
Next
If Len(eMail_Address) < 6 Then eMail_Address = vbNullString
EF: ' Return proper lower case email address if valid
eMail_Address = LCase(Replace(eMail_Address, ";", Application.International(xlListSeparator)))
EMAIL = LCase(eMail_Address)
End Function
* baixado na net e nao lembro a fonte.
Click em se a resposta foi util!
Postado : 05/09/2015 7:57 am