There is no way to prove an email is valid without sending a test mail. It
may be possible to nslookup the domain, but you still don't know if the
username is satisfactory.
The code below checks that the format is okay (i.e. that it has an
(e-mail address removed)...), and also accepts multiple addresses in the one field. To use it,
put something like this into the BeforeUpdate event of the text box where
email addresses are entered (assuming a Text field, not Hyperlink field):
If EmailBad(Me.Email, strMsg) Then
strMsg = strMsg & vbCrLf & "Continue anyway?"
If MsgBox(strMsg, vbYesNo + vbDefaultButton2 + vbQuestion, _
"Badly formed email address") <> vbYes Then
Cancel = True
End If
End If
----------------------code starts--------------------
Public Function EmailBad(varEmail As Variant, strMsg As String) As Boolean
On Error GoTo Err_EmailBad
'Purpose: Raise a flag if the argument is not a correctly formed email
address.
'Arguments: varEmail = the email address to examine.
' strMsg = MsgBox string to append problem issues to.
'Return: True if bad. False if no problem (including blank).
'Note: Can parse multiple addresses (semi-colon delimited).
Dim bBad As Boolean 'Return value.
Dim strEmail As String 'Each email address found in varEmail.
Dim lngPos As Long 'Position of separator (if multiple addresses).
Dim lngStart As Long 'Starting position of an email address within
the string.
Const conSEP = ";" 'Character separating multiple email addresses.
If Not IsError(varEmail) Then
If Not IsNull(varEmail) Then
'Parse and test each email address from the input.
lngStart = 1
lngPos = InStr(lngStart, varEmail, conSEP)
Do While lngPos > 0&
strEmail = Trim$(Mid(varEmail, lngStart, lngPos - lngStart))
If EmailBadSub(strEmail, strMsg) Then
bBad = True
End If
lngStart = lngPos + 1
lngPos = InStr(lngStart, varEmail, conSEP)
Loop
'The remainder of the string after earlier addresses parsed.
strEmail = Trim$(Mid(varEmail, lngStart, Len(varEmail) -
lngStart + 1))
If EmailBadSub(strEmail, strMsg) Then
bBad = True
End If
End If
End If
Exit_EmailBad:
EmailBad = bBad
Exit Function
Err_EmailBad:
MsgBox "Error " & Err.Number & " - " & Err.Description
Resume Exit_EmailBad
End Function
Private Function EmailBadSub(ByVal strEmail As String, strMsg As String) As
Boolean
'Purpose: Slave function for EmailBad()
'Arguments: strEmail = the email address to examine;
' strMsg = error string to append to.
'Return: True if the email was badly formed (but not if blank).
'Note: Assumes parent proc has trimmed and prepared the string.
Dim bBad As Boolean 'Return value.
Dim lngPosAt As Long 'Position of (first) @.
Dim lngPosDot As Long 'Position of first dot after @.
Dim lngLen As Long 'Length of strEmail argument.
lngLen = Len(strEmail)
If lngLen > 0& Then
'Find the (first) @ character.
lngPosAt = InStr(strEmail, "@")
Select Case lngPosAt
Case 0& 'No '@'.
bBad = True
strMsg = strMsg & "Missing '@' in '" & strEmail & "'." & vbCrLf
Case 1& 'First char.
bBad = True
strMsg = strMsg & "User name missing in '" & strEmail & "'." &
vbCrLf
Case lngLen 'Last char.
bBad = True
strMsg = strMsg & "Domain missing in '" & strEmail & "'." &
vbCrLf
End Select
'Multiple @s?
If Not bBad Then
If InStr(lngPosAt + 1&, strEmail, "@") > 0 Then
bBad = True
strMsg = strMsg & "More than one '@' in '" & strEmail & "'."
& vbCrLf
End If
End If
'The (first) dot character after the @.
If Not bBad Then
lngPosDot = InStr(lngPosAt + 1&, strEmail, ".")
Select Case lngPosDot
Case 0& 'No dot after @.
bBad = True
strMsg = strMsg & "Domain name lacks the dot in '" &
strEmail & "'." & vbCrLf
Case lngPosAt + 1& 'Dot immediately after @.
bBad = True
strMsg = strMsg & "Missing domain name between '@' and dot
in '" & strEmail & "'." & vbCrLf
Case lngLen 'Last char.
bBad = True
strMsg = strMsg & "Characers after dot missing from domain
name in '" & strEmail & "'." & vbCrLf
End Select
End If
End If
EmailBadSub = bBad
End Function
----------------------code ends--------------------
