[Resolvido]Verificar endereço de email

Boa tarde
Gostaria de saber se alguem tem uma função que verifica a validade do endereço de email?
Desde já, obrigado pela ajuda.
Abraço
MArcelo

Olá, boas noites!

Tenho esse módulo aqui, a autoria não é minha, mas, coloco a sua disposição:

Cole esse código num novo módulo e salve com o nome que desejar, ele tem a função de validar a digitação do e-mail:

Option Explicit

Public Function ValidEMail(sEMail As String) As Boolean
Dim nCharacter As Integer
Dim Count As Integer
Dim sLetra As String
'Verifica se o e-mail tem no MÍNIMO 5
'caracteres (a@b.c)
If Len(sEMail) < 5 Then
'O e-mail é inválido, pois tem menos
'de 5 caracteres
ValidEMail = False
MsgBox "O e-mail digitado tem menos de 5 " & _
"caracterec!!!"
Exit Function
End If
'Verificar a existencia de arrobas (@) no e-mail
For nCharacter = 1 To Len(sEMail)
If Mid(sEMail, nCharacter, 1) = "@" Then
'OPA!!! Achou uma arroba!!!
'Soma 1 ao contador
Count = Count + 1
End If
Next
'Verifica o número de arrobas.
'TEM que ter """UMA""" arroba
If Count <> 1 Then
'O e-mail é inválido, pois tem 0 ou
'mais de 1 arroba
ValidEMail = False
MsgBox "O nº de arrobas (@) do e-mail é " & _
"inválido!!!"
Exit Function
Else
'O e-mail tem 1 arroba.
'Verificar a posição da arroba
If InStr(sEMail, "@") = 1 Then
'O e-mail é inválido, pois começa
'com uma @
ValidEMail = False
MsgBox "O e-mail foi iniciado com uma " & _
"arroba (@)!!!"
Exit Function
ElseIf InStr(sEMail, "@") = Len(sEMail) Then
'O e-mail é inválido, pois termina
'com uma @
ValidEMail = False
MsgBox "O e-mail termina com uma arroba (@)!!!"
Exit Function
End If
End If
nCharacter = 0
Count = 0
'Verificar a existencia de pontos (.) no e-mail
For nCharacter = 1 To Len(sEMail)
If Mid(sEMail, nCharacter, 1) = "." Then
'OPA!!! Achou um ponto!!!
'Soma 1 ao contador
Count = Count + 1
End If
Next
'Verifica o número de pontos.
'TEM que ter PELO MENOS UM ponto.
If Count < 1 Then
'O e-mail é inválido, pois não tem pontos.
ValidEMail = False
MsgBox "O e-mail é inválido, pois não contém " & _
"pontos (.)!!!"
Exit Function
Else
'O e-mail tem pelo menos 1 ponto.
'Verificar a posição do ponto:
If InStr(sEMail, ".") = 1 Then
'O e-mail é inválido, pois começa
'com um ponto
ValidEMail = False
MsgBox "O e-mail foi iniciado com um ponto (.)!!!"
Exit Function
ElseIf InStr(sEMail, ".") = Len(sEMail) Then
'O e-mail é inválido, pois termina
'com um ponto.
ValidEMail = False
MsgBox "O e-mail termina com um ponto (.)!!!"
Exit Function
ElseIf InStr(InStr(sEMail, "@"), sEMail, ".") = 0 Then
'O e-mail é inválido, pois termina
'com um ponto.
ValidEMail = False
MsgBox "O e-mail não tem nenhum ponto (.) após " & _
"a arroba (@)!!!"
Exit Function
End If
End If
nCharacter = 0
Count = 0
'Verifica se o e-mail não tem pontos
'consecutivos (..) após a arroba (@).
If InStr(sEMail, "..") > InStr(sEMail, "@") Then
'O e-mail é inválido, tem pontos
'consecutivos após o @.
ValidEMail = False
MsgBox "O e-mail contém pontos consecutivos " & _
"(..) após o arroba (@)!!!"
Exit Function
End If
'Verifica se o e-mail tem caracteres
'inválidos
For nCharacter = 1 To Len(sEMail)
sLetra = Mid$(sEMail, nCharacter, 1)
If Not (LCase(sLetra) Like "[a-z]" Or sLetra = _
"@" Or sLetra = "." Or sLetra = "-" Or _
sLetra = "_" Or IsNumeric(sLetra)) Then
'O e-mail é inválido, pois tem
'caracteres inválidos
ValidEMail = False
MsgBox "Foi digitado um caracter inválido " & _
"no e-mail!!!"
Exit Function
End If
Next
nCharacter = 0
'Bem, se a verificação chegou até aqui
'é porque o e-mail é válido, então...
ValidEMail = True
End Function

---

Agora, em outro módulo novo cole este código abaixo e salve com um nome ao seu gosto. Ele serve para retirar acentos:

Option Explicit

Function SemAcentos(sString As String)
Dim X As Integer
Dim sStringFinal As String

Dim letra() As String

For X = 0 To Len(sString) - 1
ReDim Preserve letra(X)
letra(X) = Mid(sString, X + 1, 1)

If Asc(letra(X)) >= 192 Then 'Acentuados tem código >=192
Select Case letra(X)
Case "ã", "á", "â"
letra(X) = "a"
Case "é", "ê"
letra(X) = "e"
Case "í"
letra(X) = "i"
Case "ó", "ô", "õ"
letra(X) = "o"
Case "ü", "ú"
letra(X) = "u"
Case "ç"
letra(X) = "c"
Case Else
End Select
End If
Next X

For X = 0 To Len(sString) - 1
sStringFinal = sStringFinal + letra(X)
Next X

SemAcentos = sStringFinal
End Function

---

A forma de uso é a seguinte:
No campo que digita o e-mail, coloque no evento após atualizar o seguinte:

If Not IsNull(SeuCampoEmail) Then
If ValidEMail(SeuCampoEmail) = False Then
MsgBox "Atenção!!!" & Chr(13) & Chr(13) & "E-mail inválido. Confira digitação", vbCritical, "Aviso importante"
Me.SeuCampoEmail = SemAcentos(SeuCampoEmail)
End If
End If

Muito obrigado.
Irei fazer o que aconselhas e retorno .
Desde já obrigado.

Marcelo

Funcionou muito bem.
Apenas da erro quando tento colocar o foco no campo email, após localizar o erro.
O código não aceita o comando "TxtEmail.setfocus"

E o nome do campo é txtEmail ou simplesmente EMail?

Txtemail

Então veja se a terminologia está certa , basta um erro, por exemplo um T grande em vez de um t pequeno. Verifique por favor.

Isto esta correto.
Somente da o erro quando coloco o comando: TxtEmail.setfocus
O erro é o seguinte: você deve salvar o campo antes de usar o setfocus.
Isto não estou entendendo.

Não estou a ver o local aonde está o setfocus, mas pode estar num local errado no código. Tente mudar. Assim fica difícil.

fica dificil mesmo,

Está colocando em qual parte do campo (dentro do if ou fora) em qual local?

Qual o nome do campo (txtEmail ou txtemail)? Cuidado para não confundir fonte de registro com nome de controle, verifique.

Consegui resolver meu problema. Estava colocando no evento errado.
Utilizei no after update e deu tudo certo.
Obrigado pela ajuda

Marcelo

Como lhe disse, estava na parte errada. Obrigado pelo retorno e um forte abraço.