Public Function IsValidEMailAddress( _
      ByVal EMailAddress As String, _
      Optional ByVal Strict As Boolean = False _
   ) As Boolean
   
' Return True if the email address referenced is valid, False otherwise.
   
   Const Domain_Extensions = "|aero|biz|com|coop|edu|gov|info|int|mil|museum|name|net|org|pro|travel|"
   Const Country_Extensions = "|ac|ad|ae|af|ag|ai|al|am|an|ao|aq|ar|as|at|au|aw|ax|az|ba|bb|bd|be|bf|bg|bh|bi|bj|bm|bn|bo|br|bs|bt|bv|bw|by|bz|ca|cc|cd|cf|cg|ch|ci|ck|cl|cm|cn|co|cr|cs|cu|cv|cx|cy|cz|de|dj|dk|dm|do|dz|ec|ee|eg|eh|er|es|et|eu|fi|fj|fk|fm|fo|fr|ga|gb|gd|ge|gf|gg|gh|gi|gl|gm|gn|gp|gq|gr|gs|gt|gu|gw|gy|hk|hm|hn|hr|ht|hu|id|ie|il|im|in|io|iq|ir|is|it|je|jm|jo|jp|ke|kg|kh|ki|km|kn|kp|kr|kw|ky|kz|la|lb|lc|li|lk|lr|ls|lt|lu|lv|ly|ma|mc|md|mg|mh|mk|ml|mm|mn|mo|mp|mq|mr|ms|mt|mu|mv|mw|mx|my|mz|na|nc|ne|nf|ng|ni|nl|no|np|nr|nu|nz|om|pa|pe|pf|pg|ph|pk|pl|pm|pn|pr|ps|pt|pw|py|qa|re|ro|ru|rw|sa|sb|sc|sd|se|sg|sh|si|sj|sk|sl|sm|sn|so|sr|st|sv|sy|sz|tc|td|tf|tg|th|tj|tk|tl|tm|tn|to|tp|tr|tt|tv|tw|tz|ua|ug|uk|um|us|uy|uz|va|vc|ve|vg|vi|vn|vu|wf|ws|ye|yt|yu|za|zm|zw|"
   Const Invalid_Chars = "/'\"";:?!()[]{}^| "
   Const Invalid_Chars_Strict = "/'\"";:?!()[]{}^|$&*+=`<>,% "
   Const Invalid_Domains = "|aso|dnso|icann|internic|pso|afrinic|apnic|arin|example|gtld-servers|iab|iana|iana-servers|iesg|ietf|irtf|istf|lacnic|latnic|rfc -editor|ripe|root-servers|nic|whois|www|arpa|"
   
   Dim Index As Long
   Dim Extension As String
   Dim Domain As String
   Dim Position1 As Long
   Dim Position2 As Long
   
   If Len(EMailAddress) = 0 Then
      IsValidEMailAddress = True
      Exit Function
   End If
   
   EMailAddress = LCase(EMailAddress)
   
   ' Check for invalid characters
   If Strict Then
      For Index = 1 To Len(EMailAddress)
         If InStr(Invalid_Chars_Strict, Mid(EMailAddress, Index, 1)) > 0 Then
            Exit Function
         End If
      Next Index
   Else
      For Index = 1 To Len(EMailAddress)
         If InStr(Invalid_Chars, Mid(EMailAddress, Index, 1)) > 0 Then
            Exit Function
         End If
      Next Index
   End If
   
   ' Check for valid extension
   Index = InStrRev(EMailAddress, ".")
   If Index = 0 Then Exit Function
   Extension = Mid(EMailAddress, Index + 1)
   If InStr(Domain_Extensions, "|" & Extension & "|") = 0 And InStr(Country_Extensions, "|" & Extension & "|") = 0 Then Exit Function
   
   ' Check for consecutive dots
   If InStr(EMailAddress, "..") > 0 Then Exit Function
   
   ' Check for more than one ampersand
   If InStr(Replace(EMailAddress, "@", " ", Count:=1), "@") > 0 Then Exit Function
   
   ' Check for text prior to the ampersand
   Index = InStr(EMailAddress, "@")
   If Not Index > 1 Then Exit Function
   
   ' Check for a period after the ampersand
   If Mid(EMailAddress, Index + 1, 1) = "." Then Exit Function
   
   Position1 = InStr(EMailAddress, "@") + 1
   Position2 = InStr(Position1, EMailAddress, ".") - 1
   Domain = Mid(EMailAddress, Position1, Position2 - Position1 + 1)
   
   If Strict Then
      ' Check for single character domain
      If Len(Domain) = 1 Then Exit Function
      ' Check for an invalid domain
      If InStr(Invalid_Domains, "|" & Domain & "|") > 0 Then Exit Function
      If InStr(Domain_Extensions, "|" & Domain & "|") > 0 Then Exit Function
   End If
   
   ' Check for dash in the first, last, third, or fourth position of the domain
   If Left(Domain, 1) = "-" Then Exit Function
   If Right(Domain, 1) = "-" Then Exit Function
   If Len(Domain) > 2 Then
      If Mid(Domain, 3, 1) = "-" Then Exit Function
      If Len(Domain) > 3 Then
         If Mid(Domain, 4, 1) = "-" Then Exit Function
      End If
   End If
   
   ' Check for more then 67 characters in the domain and extension
   If Len(Domain) + Len(Extension) > 67 Then Exit Function
   
   IsValidEMailAddress = True

End Function