como validar email vba

Boa tarde estou a criar um sistema "Gestão de Stock" para empresa onde estou a estagiar , e queria validar alguns campos no formulário fornecedor, Funcionário, e clientes. Quando o utilizador digitar um email verifica se o email esta correto.
Este caso é devido se no caso algum utilizador digitar algum caracter invalido com no caso de virgula, Ife ou se esqueceu do arroba, a automaticamente emite uma massagem de erro "por favor verifique se o email bem escrito!" e não pode ter espaço.
Agradeço imenso quem poder me ajudar.

E se criar três campos para o email:

Email: @.

Utilizo esta função.

Código:

'Validar e-mails digitados
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 caracteres."
    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
'No evento que quiser usar
Dim VALID As Boolean
    VALID = ValidEMail(Me.camp2.Value)
       
        If VALID = False Then
            MsgBox "E-mail inválido."
        End If


Valeu!

Claro que não tem todas as regras de email aqui possíveis, mas uma solução bem boba que criei foi adicionar uma REGRA DE VALIDAÇÃO diretamente no campo da tabela que armazena o email

Abrindo em modo design, na folha de propriedades encontre a linha "regra de validação" e adicione o seguinte:

((Negado Como "*[ ,;/çãâáàèéêíìòõóôùúü'´`~!#$¨()<>+^:]*") E (Negado Como "*?@@?*") E (Negado Como "*?..?*") E (Negado Como "*?@hotmai.com") E (Negado Como "*?@hotail.com") E (Negado Como "*?@hotmaill.com") E (Negado Como "*?@hotmal.com") E (Negado Como "*?@homail.com") E (Negado Como "*?@homtail.com") E (Negado Como "*?@hormail.com") E (Negado Como "*?@hotmail.com.com") E (Negado Como "*?@gmail.com.br?*") E (Negado Como "*?@gmial.com") E (Negado Como "*?@gmal.com") E (Negado Como "*?@gamil.com") E (Negado Como "*?@gmaill.com") E (Negado Como "*?@gmil.com") E (Negado Como "*?@yhaoo.com") E (Negado Como "*?@yahaoo.com") E (Como "*?@?*.?*"))



Com esse código inclusive é verificado alguns erros de digitação mais comuns mas a função principal esta no final: Como "*?@?*.?*" e as do começo que não permitem caracteres especiais e nem duas arrobas e dois pontos seguidos. O resultado êh razoavelmente bacana e nem envolve VBA

Depois em texto de validação escreva:

ERRO! Email inválido! Verifique se há caracteres especiais ou erro de digitação!
Espero ter ajudado.

Abraco

Aproveitee veja na minha assinatura o link 102 Codigos.

Com a permissão dos colegas, a tempos atrás criei uma função em VB para validar Email. Abaixo deixo a mesma adaptada para o VBA:

Código:

    Public Function valEmail(ByVal cEmail As String) As Boolean

        valEmail = True

        Dim nUser As Variant
        nUser = Split(cEmail, "@")

        If UBound(nUser) < 1 Or UBound(nUser) > 1 Or Len(nUser(0)) < 1 Then
            valEmail = False
        Else
            Dim nServer As Variant
            nServer = Split(nUser(1), ".")
            If UBound(nServer) < 1 Or Len(nServer(LBound(nServer))) < 1 Or Len(nServer(UBound(nServer))) < 1 Then
                valEmail = False
            End If
        End If

    End Function

Primeiramente usamos o Split para verificar a quantidade de arrobas(@). Se for diferente de 1 ou se a primeira parte o arroba tiver menos de 1 caractere, retorna Falso. Caso contrário, utilizaremos o Split para dividir a segunda parte, depois do arroba, tendo o ponto como referência. Aqui aplicaremos novamente a contagem de arrays e a contagem de caracteres em cada array. Se não tiver pelo menos duas arrays ou se a quantidade de caracteres da primeira e da última array for menor que um, retorna falso. Caso contrário, retorna verdadeiro.

Agora, no clique do botão, algo assim:

Código:

If valEmail(txtEmail) = False Then
        MsgBox "Email inválido"
Else
        Prossegue...
End If

No evento "Ao apertar tecla" pode-se ainda filtrar as teclas para aceitar apenas letras, números, o arroba, o ponto, hífen e underline:

Código:

    If KeyCode = 8 Or KeyCode = 13 Or KeyCode = 35 Or KeyCode = 36 Or KeyCode = 45 Or KeyCode = 46 Or KeyCode = 64 Or KeyCode = 95 Or KeyCode = 189 Or KeyCode = 190 Or (KeyCode > 47 And KeyCode < 58) Or (KeyCode > 64 And KeyCode < 91) Or (KeyCode > 95 And KeyCode < 106) Then
    Else
        KeyCode = 0
    End If