none
VBA function for checking email syntax validity RRS feed

  • Question

  • Is there any VBA function available for checking the syntax validity for email ?

    If you have, appreciate you can share with me.

    Thank you.


    TS Lim
    Tuesday, August 30, 2011 2:00 AM

Answers

  • Here's how I do it.

    Here is the code on the before update event for the textbox where user types in the email address:

    Private Sub PhoneEmail_BeforeUpdate(Cancel As Integer)
    On Error GoTo Err_Handler

        Dim strTxt As String
        Dim strMsg As String
       

            strTxt = Me.PhoneEmail.Text
            If Len(strTxt) > 0 Then
                strMsg = PassEmailAddress(strTxt)
                'Debug.Print strMsg
                If Len(strMsg) > 0 Then
                    Cancel = True
                    MsgBox strMsg
                End If
            End If


    Exit_Handler:
        Exit Sub
    Err_Handler:
        Debug.Print Err.Number, Err.Description, Now
        Resume Exit_Handler
    End Sub

     

    Here's the code for the function called PassEmailAddress

    Public Function PassEmailAddress(ByVal strEmail As String, _
                        Optional ByRef strReason As String) As String
    On Error GoTo Err_Handler

        Dim strPrefix As String
        Dim strSuffix As String
        Dim strMiddle As String
        Dim lngCharacter As Long
        Dim strBuffer As String
        Dim blnContinue As String
        Dim strMsg As String
       
        blnContinue = True
        'default = true
       
        strEmail = Trim(strEmail)
       
        If Len(strEmail) < 8 Then
            strReason = "Too short for a valid email address."
            blnContinue = False
        End If
          
        If blnContinue = True Then
            strMsg = CheckAt(strEmail)
            If Len(strMsg) > 0 Then
                blnContinue = False
                strReason = strMsg
            End If
        End If
       
       
        PassEmailAddress = strReason
        'strReason = Empty
        'Dropped through to here, so email address OK

    Exit_Handler:
        Exit Function
    Err_Handler:
        PassEmailAddress = False
        Debug.Print Err.Number, Err.Description,Now
        Resume Exit_Handler

    End Function

    Private Function CheckAt(strTxtIn As String) As String
    On Error GoTo Err_Handler

        Dim lngCharacter As Long
        Dim strMsg As String
        Dim strBuffer As String
        Dim strBuffer2 As String
        Dim strReason As String
        Dim blnContinue As String
       
        blnContinue = True
        'default = true
       
        strBuffer = strTxtIn
        If InStr(strBuffer, "@") = 0 Then
            strReason = "Missing the @ needed in a valid email address."
            blnContinue = False
        End If
       
        If blnContinue = True Then
            If InStr(InStr(strBuffer, "@") + 1, strBuffer, "@") < 0 Then
                strReason = "Too many @ for a valid email address"
                blnContinue = False
            End If
        End If
       
        If blnContinue = True Then
            If InStr(strBuffer, ".") = 0 Then
                strReason = "Missing the period needed in a valid email address."
                blnContinue = False
            End If
        End If
           
        If blnContinue = True Then
            If InStr(strBuffer, "@") = 1 Or InStr(strBuffer, "@") = Len(strBuffer) Or _
                InStr(strBuffer, ".") = 1 Or InStr(strBuffer, ".") = Len(strBuffer) Then
                strReason = "Not a valid format for an email address."
                blnContinue = False
            End If
        End If
          
        On Error Resume Next
        If blnContinue = True Then
            strBuffer = Right(strBuffer, 4)
            If InStr(strBuffer, ".") = 0 Then
                strMsg = TooLong(strBuffer)
                If Len(strMsg) > 0 Then
                    blnContinue = False
                    strReason = strMsg
                End If
            End If
        End If
       
        If blnContinue = True Then
            If Left(strBuffer, 1) = "." Then strBuffer = Right(strBuffer, 3)
            If Left(Right(strBuffer, 3), 1) = "." Then strBuffer = Right(strBuffer, 2)
            If Left(Right(strBuffer, 2), 1) = "." Then strBuffer = Right(strBuffer, 1)
           
            If Len(strBuffer) < 2 Then
                strReason = "Suffix (ending) too short for a valid email address."
                blnContinue = False
            End If
        End If

        CheckAt = strReason
       
    Exit_Handler:
        Exit Function
    Err_Handler:
        Debug.Print Err.Number, Err.Description, Now
        Resume Exit_Handler
    End Function

    Private Function TooLong(strTxtIn As String) As String
    On Error GoTo Err_Handler

        Dim strReason As String
       
        If Len(strTxtIn) > 3 Then
            strReason = "Suffix (ending) too long for a valid email address."
            TooLong = strReason
        End If

    Exit_Handler:
        Exit Function
    Err_Handler:
        Debug.Print Err.Number, Err.Description, Now
        Resume Exit_Handler
    End Function



    Jeanette Cunningham
    • Marked as answer by TS Lim Tuesday, August 30, 2011 4:35 AM
    Tuesday, August 30, 2011 2:28 AM

All replies

  • Here's how I do it.

    Here is the code on the before update event for the textbox where user types in the email address:

    Private Sub PhoneEmail_BeforeUpdate(Cancel As Integer)
    On Error GoTo Err_Handler

        Dim strTxt As String
        Dim strMsg As String
       

            strTxt = Me.PhoneEmail.Text
            If Len(strTxt) > 0 Then
                strMsg = PassEmailAddress(strTxt)
                'Debug.Print strMsg
                If Len(strMsg) > 0 Then
                    Cancel = True
                    MsgBox strMsg
                End If
            End If


    Exit_Handler:
        Exit Sub
    Err_Handler:
        Debug.Print Err.Number, Err.Description, Now
        Resume Exit_Handler
    End Sub

     

    Here's the code for the function called PassEmailAddress

    Public Function PassEmailAddress(ByVal strEmail As String, _
                        Optional ByRef strReason As String) As String
    On Error GoTo Err_Handler

        Dim strPrefix As String
        Dim strSuffix As String
        Dim strMiddle As String
        Dim lngCharacter As Long
        Dim strBuffer As String
        Dim blnContinue As String
        Dim strMsg As String
       
        blnContinue = True
        'default = true
       
        strEmail = Trim(strEmail)
       
        If Len(strEmail) < 8 Then
            strReason = "Too short for a valid email address."
            blnContinue = False
        End If
          
        If blnContinue = True Then
            strMsg = CheckAt(strEmail)
            If Len(strMsg) > 0 Then
                blnContinue = False
                strReason = strMsg
            End If
        End If
       
       
        PassEmailAddress = strReason
        'strReason = Empty
        'Dropped through to here, so email address OK

    Exit_Handler:
        Exit Function
    Err_Handler:
        PassEmailAddress = False
        Debug.Print Err.Number, Err.Description,Now
        Resume Exit_Handler

    End Function

    Private Function CheckAt(strTxtIn As String) As String
    On Error GoTo Err_Handler

        Dim lngCharacter As Long
        Dim strMsg As String
        Dim strBuffer As String
        Dim strBuffer2 As String
        Dim strReason As String
        Dim blnContinue As String
       
        blnContinue = True
        'default = true
       
        strBuffer = strTxtIn
        If InStr(strBuffer, "@") = 0 Then
            strReason = "Missing the @ needed in a valid email address."
            blnContinue = False
        End If
       
        If blnContinue = True Then
            If InStr(InStr(strBuffer, "@") + 1, strBuffer, "@") < 0 Then
                strReason = "Too many @ for a valid email address"
                blnContinue = False
            End If
        End If
       
        If blnContinue = True Then
            If InStr(strBuffer, ".") = 0 Then
                strReason = "Missing the period needed in a valid email address."
                blnContinue = False
            End If
        End If
           
        If blnContinue = True Then
            If InStr(strBuffer, "@") = 1 Or InStr(strBuffer, "@") = Len(strBuffer) Or _
                InStr(strBuffer, ".") = 1 Or InStr(strBuffer, ".") = Len(strBuffer) Then
                strReason = "Not a valid format for an email address."
                blnContinue = False
            End If
        End If
          
        On Error Resume Next
        If blnContinue = True Then
            strBuffer = Right(strBuffer, 4)
            If InStr(strBuffer, ".") = 0 Then
                strMsg = TooLong(strBuffer)
                If Len(strMsg) > 0 Then
                    blnContinue = False
                    strReason = strMsg
                End If
            End If
        End If
       
        If blnContinue = True Then
            If Left(strBuffer, 1) = "." Then strBuffer = Right(strBuffer, 3)
            If Left(Right(strBuffer, 3), 1) = "." Then strBuffer = Right(strBuffer, 2)
            If Left(Right(strBuffer, 2), 1) = "." Then strBuffer = Right(strBuffer, 1)
           
            If Len(strBuffer) < 2 Then
                strReason = "Suffix (ending) too short for a valid email address."
                blnContinue = False
            End If
        End If

        CheckAt = strReason
       
    Exit_Handler:
        Exit Function
    Err_Handler:
        Debug.Print Err.Number, Err.Description, Now
        Resume Exit_Handler
    End Function

    Private Function TooLong(strTxtIn As String) As String
    On Error GoTo Err_Handler

        Dim strReason As String
       
        If Len(strTxtIn) > 3 Then
            strReason = "Suffix (ending) too long for a valid email address."
            TooLong = strReason
        End If

    Exit_Handler:
        Exit Function
    Err_Handler:
        Debug.Print Err.Number, Err.Description, Now
        Resume Exit_Handler
    End Function



    Jeanette Cunningham
    • Marked as answer by TS Lim Tuesday, August 30, 2011 4:35 AM
    Tuesday, August 30, 2011 2:28 AM
  • Dear Jeanettte,

    Thank you very much for the answer.

    I have added the following to check if there is any domain name present. 

    From your answer:

    If blnContinue = True Then
      If InStr(strBuffer, "@") = 1 Or InStr(strBuffer, "@") = Len(strBuffer) Or _
          InStr(strBuffer, ".") = 1 Or InStr(strBuffer, ".") = Len(strBuffer) Then
        strReason = "Not a valid format for an email address."
        blnContinue = False
      End If
    End If
           
    What I added after the above:


    If blnContinue = True Then
      If InStr(strBuffer, "@.") > 0 Then
        strReason = "Missing domain name."
        blnContinue = False
      End If
    End If

    By the way, do you have any info about the criteria for the domain name, should it  be  alpha character only ? Is there any condition for the number of characters ?

    Thank you.

     


    TS Lim
    Tuesday, August 30, 2011 4:35 AM
  • Dear Jeanette,

    Can you also advise about the characters allow for the name, domain name and suffix , so that we can enhance the function to have a more complete check.

     


    TS Lim
    Tuesday, August 30, 2011 4:45 AM
  • Sorry, I don't have any code to check the domain name - they are so variable - I don't bother to check this.
    Jeanette Cunningham
    Tuesday, August 30, 2011 5:18 AM
  • Dear Jeanette,

    You are right, the domain names are so varaible. I did check form the website and got some info about the domain name and their criteria.

    Thank you again for your VBA solution. from there I am able to add a few more checking criteria, following the way in your functions and procedures, by adding a few more "If blnContinue = Trun ... End if"

    Thank you.
     


    TS Lim
    Tuesday, August 30, 2011 11:10 AM
  • Just tried this with "testing at at hello.com" and it didn't catch the two "@" signs.

    Thursday, April 18, 2013 7:22 PM
  • Just tried this with "testing at at hello.com" and it didn't catch the two "@" signs.

    I haven't tested Jeanette's function, but I use this to validate e-mail addresses:

    Function IsValidEmailAddress(Candidate As String) As Boolean
    
        If Trim(Candidate) Like "?*@[!.]*.[!.]*" Then
            If Not Candidate Like "*@*@*" Then
                IsValidEmailAddress = True
            End If
        End If
    
    End Function
    

    I believe there may be some legal addresses that it rejects, but I haven't seen them.  If you want to get into it even deeper, I think a search for regular expressions ("regex") to validate e-mail addresses would be fruitful.


    Dirk Goldgar, MS Access MVP
    Access tips: www.datagnostics.com/tips.html

    Thursday, April 18, 2013 10:32 PM
  • The easiest, and best technique in my opinion, is to use RegEx (like in most programming languages) to find patterns.    See: http://www.devhut.net/2010/12/06/vba-validate-email-address/ and http://www.devhut.net/2010/06/22/vba-regular-rxpressions-regex/

    You could use a simple pattern such as:

    (\w[-._\w]*\w@\w[-._\w]*\w\.\w{2,3})

    or if you want to comply with RFC 822 specs, you'd use comething along the lines of:

    (?<user>(?:(?:[^ \t\(\)\<\>@,;\:\\\"\.\[\]\r\n]+)|(?:\"(?:(?:[^\"\\\r\n])|(?:\\.))*\"))(?:\.(?:(?:[^ \t\(\)\<\>@,;\:\\\"\.\[\]\r\n]+)|(?:\"(?:(?:[^\"\\\r\n])|(?:\\.))*\")))*)@(?<domain>(?:(?:[^ \t\(\)\<\>@,;\:\\\"\.\[\]\r\n]+)|(?:\[(?:(?:[^\[\]\\\r\n])|(?:\\.))*

    So with this, in 3 lines of code, you can validate any e-mail address.  That's the power of RegEx!


    Daniel Pineault, 2010-2012 Microsoft MVP
    http://www.cardaconsultants.com
    MS Access Tips and Code Samples: http://www.devhut.net

    Friday, April 19, 2013 12:24 AM
  • Private Sub mftb_MailId_Exit(ByVal Cancel As MSForms.ReturnBoolean)
       If blnEmailValid(mftb_MailId.Text) = False Then
            Response = MsgBox("please check your mail id", vbOKOnly)
            If Response = vbOK Then
                mftb_MailId.SetFocus
            End If
        End If
            
    End Sub
    Public Function blnEmailValid(ByVal strEmailAdd As String) As Boolean
    'MsgBox ("ok")
        With CreateObject("VBScript.RegExp")
            .IgnoreCase = True
            .Global = True
            .Pattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
            blnEmailValid = .Test(strEmailAdd)
        End With
        
    End Function
    Monday, October 21, 2013 9:03 AM

  • This is essentially the same as the code proposed by patilrupeshd 5 years ago.

    Dirk Goldgar, MS Access MVP
    Access tips: www.datagnostics.com/tips.html

    Tuesday, July 31, 2018 6:29 PM
  • Daniel

    Thank you very much!


    Cheers // Peter Forss Stockholm

    Tuesday, October 29, 2019 9:48 AM