VBA - How to manage invalid email address when sending email from Excel

[Kerryx]

Hi ok had this issue recently and want to see if anyone has a solution or work around, We use contact list in Excel to send emails to the group list
and this is the part of the code that handles the addresses, list limited to max 100 contacts with Gmail ( another problem for another day)
but what was happening was that even though testing and all worked well when sending to actual contact list it kept coming back saying " Email was not sent", and after an intense few days i found the issue was that when entering the email addresses someone had entered theirs as " joexxxx@:hotmail.com" note the colon ) after the @ symbol , stopped everything in its tracks.
I am assuming that this was down to Gmail and the email message was not sent because it has an invalid TO address.

So question is is there something I can add to the code to inform me that one of the address is invalid or is there some other VBA to check that email adresses are correct, everything I have looked at basically checks to see if email addresses contain an @ or . nothing that checks for invalid character after the @.​

Code below is part that handles the addresses

For Each r In Sheets("Admin").Range("A9:A108") ''' range containing the distribution list
       If Len(strAddressees) = 0 Then
         strAddressees = r
      Else
         strAddressees = strAddressees & "; " & r
      End If
     Next

        .To = strAddressees
        .CC = ""
        .BCC = ""
        .From = """The Club"" <ThaMainClub@gmail.com>"
        .Subject = "Results"
        .HTMLBody = rangetohtml(r2)

         .TextBody = "Hi all" & vbNewLine & vbNewLine & _
        "Attached please find updated Results" & vbNewLine & vbNewLine & _
        "Last updated " & Sheets("admin").Range("a2") & vbNewLine & vbNewLine & _
        Sheets("Admin").Range("B4") & vbNewLine & _
        Sheets("Admin").Range("B5")

        .AddAttachment FileFullPath                
       
   On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
    MsgBox "E-mail was not sent", vbExclamation
    Else
     MsgBox "E-mail successfully sent", vbInformation
    End If

 

[portews]

Try this:

For Each r In Sheets("Admin").Range("A9:A125") ''' range containing the distribution list
'check for the @ symbol
    If Not InStr(r, "@") > 0 Then whoops = whoops & vbNewLine & r: GoTo skipit
    'find just the domain name
    chkdom = Right(r, Len(r) - InStrRev(r, "@"))
    'check for a period in the domain name
    If Not InStr(chkdom, ".") > 0 Then whoops = whoops & vbNewLine & r: GoTo skipit
    'check each letter in the domain name for forbidden characters
    For i = 1 To Len(chkdom)
        Select Case Asc(Mid(chkdom, i, 1))
        Case 32 To 38, 40 To 44, 47, 58, 59, 61, 63, 64, 91 To 96, 123 To 126, 145, 148
            'if you find them, put them in a list...
            whoops = whoops & vbNewLine & r
            'and go to the next address
            GoTo skipit
        End Select
    Next
    'if it's ok, add it to the list
    strAddressees = strAddressees & "; " & r
skipit:
Next
'if the list of bad addresses is >0
If Len(whoops) > 0 Then
    'pop a message box
    x = MsgBox("The following domain names are invalid." & vbNewLine & "Select OK to continue, Cancel to correct" _
    & vbNewLine & whoops, vbOKCancel, "Domain Error")
    'if they hit Cancel, stop the process.  If they hit OK, it will continue with the valid addresses
    If x = 2 Then End
End If

.To = strAddressees

code continues on from here.

 

[Kerryx]

Sweet, thank you very much, on testing it works but Msg box showing Domain Error extends from top to below bottom of screen, so unable to see buttons, any way to tighten it up.

 

[Kerryx]

Marking it as a solution as it gives me the checks i need, really appreciate it.

 

[portews]

I'm assuming that the Range("A9:A125") is an arbitrary number and that there are a lot of blanks up to that number?

If so, substitute that line with:

LastRow = Sheets("Admin").Range("A" & Rows.Count).End(xlUp).Row
For Each r In Sheets("Admin").Range("A9:A"&LastRow)

 

[Kerryx]

Thank you appreciate the assist