Suggest improvement for Email Format Validation for Textbox (1 Viewer)

Option Compare Database
Option Explicit
' This is an example of what goes in a Textbox Before Update
Private Sub ContactEmail_BeforeUpdate(Cancel As Integer)
      ' Code to use in a before update event in a text box to validate Email address
10    On Error GoTo Err_Handler
          Dim strTxt As String
          Dim strMsg As String
20            'strTxt = Me.PhoneEmail.Text  ' Uncomment once in a form module
30            If Len(strTxt) > 0 Then
40                strMsg = PassEmailAddress(strTxt)
                  'Debug.Print strMsg
50                If Len(strMsg) > 0 Then
60                    Cancel = True
70                    MsgBox strMsg
80                End If
90            End If

Exit_Handler:
100       Exit Sub
Err_Handler:
110       Debug.Print Err.Number, Err.Description, Now
120       Resume Exit_Handler
End Sub
' This would be placed in a general module
' Calls the code to check for basic valid email construction
' Test in Immediate Window:     ? PassEmailAddress("Rx_@NSA.Gov", "Passed")
Public Function PassEmailAddress(ByVal strEmail As String, _
                    Optional ByRef strReason As String) As String
10    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
          
20        blnContinue = True
          'default = true
          
30        strEmail = Trim(strEmail)
          
40        If Len(strEmail) < 8 Then
50            strReason = "Too short for a valid email address."
60            blnContinue = False
70        End If
             
80        If blnContinue = True Then
90            strMsg = CheckAt(strEmail)
100           If Len(strMsg) > 0 Then
110               blnContinue = False
120               strReason = strMsg
130           End If
140       End If
          
          
150       PassEmailAddress = strReason
          'strReason = Empty
          'Dropped through to here, so email address OK

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

End Function

Private Function CheckAt(strTxtIn As String) As String
10    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
          
20        blnContinue = True
          'default = true
          
30        strBuffer = strTxtIn
40        If InStr(strBuffer, "@") = 0 Then
50            strReason = "Missing the @ needed in a valid email address."
60            blnContinue = False
70        End If
80        If blnContinue = True Then
90            If InStr(strBuffer, "@.") > 0 Then
100               strReason = "Missing domain name."
110               blnContinue = False
120           End If
130       End If
140       If blnContinue = True Then
150           If InStr(InStr(strBuffer, "@") + 1, strBuffer, "@") < 0 Then
160               strReason = "Too many @ for a valid email address"
170               blnContinue = False
180           End If
190       End If
200       If blnContinue = True Then
210           If InStr(strBuffer, ".") = 0 Then
220               strReason = "Missing the period needed in a valid email address."
230               blnContinue = False
240           End If
250       End If
260       If blnContinue = True Then
270           If InStr(strBuffer, "@") = 1 Or InStr(strBuffer, "@") = Len(strBuffer) Or _
                  InStr(strBuffer, ".") = 1 Or InStr(strBuffer, ".") = Len(strBuffer) Then
280               strReason = "Not a valid format for an email address."
290               blnContinue = False
300           End If
310       End If
320       If Trim(strBuffer) Like "?*@[!.]*.[!.]*" Then
330     If Not strBuffer Like "*@*@*" Then
            'Checks for @@
340     Else
350         strReason = "Double character Not a valid format for an email address."
360         blnContinue = False
370     End If
380       End If
390       On Error Resume Next
400       If blnContinue = True Then
410           strBuffer = Right(strBuffer, 4)
420           If InStr(strBuffer, ".") = 0 Then
430               strMsg = TooLong(strBuffer)
440               If Len(strMsg) > 0 Then
450                   blnContinue = False
460                   strReason = strMsg
470               End If
480           End If
490       End If
          
500       If blnContinue = True Then
510           If Left(strBuffer, 1) = "." Then strBuffer = Right(strBuffer, 3)
520           If Left(Right(strBuffer, 3), 1) = "." Then strBuffer = Right(strBuffer, 2)
530           If Left(Right(strBuffer, 2), 1) = "." Then strBuffer = Right(strBuffer, 1)
              
540           If Len(strBuffer) < 2 Then
550               strReason = "Suffix (ending) too short for a valid email address."
560               blnContinue = False
570           End If
580       End If

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

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

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

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