Notifications
Clear all

Validar e-mail

3 Posts
2 Usuários
0 Reactions
951 Visualizações
(@trindade)
Posts: 0
New Member
Topic starter
 

Boa noite, Srs.

Alguém teria alguma indicação para validação de TexboxBox que ira receber e-mail.
Além de validar o "@" valida-se também o .com, .br, .net e tudo mais.

Qualquer ajuda é bem vinda.

 
Postado : 04/09/2015 6:30 pm
(@basole)
Posts: 487
Reputable Member
 

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.

 
Postado : 05/09/2015 7:57 am
(@trindade)
Posts: 0
New Member
Topic starter
 

Bom dia, Basole.

Muito obrigado pelo código.
Segue como ficou o código em meu TextBox:

Private Sub TextBoxEmail_Change()

    If TextBoxEmail.Text = Email(Me.TextBoxEmail.Text) Then
    
        With TextBoxEmail
           .BackColor = RGB(255, 255, 255)
        End With
    
    Else
    
        With TextBoxEmail
           .BackColor = RGB(255, 163, 163)
        End With
        
    End If

End Sub
 
Postado : 05/09/2015 10:45 am