Multiple Email Address Validation

[austin350s10]

Is there a way to validate more than one email address when entered into an Application.InputBox?

EXAMPLE:
The user can enter just one email address like: test@test.com
or the user can enter multiple email addresses like: test@test.com;test2@test.com


Below is a sweet script I found that will check to see if just one email address is valid. Is there anyway this could be modified to include multiple email addresses separated by the ";" character??

Sub email()
    Dim txtEmail As String
    txtEmail = InputBox("Type the address", "e-mail address")
     
    Dim Situacao As String
     
     ' Check e-mail syntax
    If IsEmailValid(txtEmail) Then
        Situacao = "Valid e-mail syntax!"
    Else
        Situacao = "Invalid e-mail syntax!"
    End If
     ' Shows the result
    MsgBox Situacao
End Sub
Function IsEmailValid(strEmail)
    Dim strArray As Variant
    Dim strItem As Variant
    Dim i As Long, c As String, blnIsItValid As Boolean
    blnIsItValid = True
     
    i = Len(strEmail) - Len(Application.Substitute(strEmail, "@", ""))
    If i <> 1 Then IsEmailValid = False: Exit Function
    ReDim strArray(1 To 2)
    strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)
    strArray(2) = Application.Substitute(Right(strEmail, Len(strEmail) - Len(strArray(1))), "@", "")
    For Each strItem In strArray
        If Len(strItem) <= 0 Then
            blnIsItValid = False
            IsEmailValid = blnIsItValid
            Exit Function
        End If
        For i = 1 To Len(strItem)
            c = LCase(Mid(strItem, i, 1))
            If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
                blnIsItValid = False
                IsEmailValid = blnIsItValid
                Exit Function
            End If
        Next i
        If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then
            blnIsItValid = False
            IsEmailValid = blnIsItValid
            Exit Function
        End If
    Next strItem
    If InStr(strArray(2), ".") <= 0 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    i = Len(strArray(2)) - InStrRev(strArray(2), ".")
    If i <> 2 And i <> 3 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    If InStr(strEmail, "..") > 0 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    IsEmailValid = blnIsItValid
End Function

 

[VoG]

Try

Sub email()
Dim txtEmail As String
Dim i As Integer, X
Dim Situacao As String
txtEmail = InputBox("Type the addresses separated by ;", "e-mail address")
X = Split(txtEmail, ";")
For i = LBound(X) To UBound(X)
' Check e-mail syntax
    If IsEmailValid(X(i)) Then
        Situacao = "Address " & i + 1 & " " & X(i) & " valid e-mail syntax!"
    Else
        Situacao = "Address " & i + 1 & " " & X(i) & " invalid e-mail syntax!"
    End If
    ' Shows the result
    MsgBox Situacao
Next i
End Sub

 

[austin350s10]

Thats perfect. Only thing is I plan on using this script to use what the person typed into the InputBox as the SendTo. If I write

.SendTo txtEmail

it just returns what the person typed in originally. Errors and all.

Is there a way to strip out any invalid email addresses and assign the the new list to a variable?
Or allow the user to correct there mistake without having to re-enter all the same email addresses. Maybe bring them back to the InputBox pre-filled in with their last entry and force them to fix there mistake before continuing?

Thanks Again,

 

[VoG]

Perhaps this: you would need to check that txtEmail isn't "" before sending

Sub email()
Dim txtEmail As String
Dim i As Integer, X
Dim Situacao As String
Dim Pass As Boolean, temp As String
Pass = True
txtEmail = InputBox("Type the addresses separated by ;", "e-mail address")
X = Split(txtEmail, ";")
For i = LBound(X) To UBound(X)
' Check e-mail syntax
    If IsEmailValid(X(i)) Then
        Situacao = Situacao & "Address " & i + 1 & vbTab & X(i) & vbTab & "valid e-mail syntax!" & vbNewLine
        temp = temp & X(i) & ";"
    Else
        Situacao = Situacao & "Address " & i + 1 & vbTab & X(i) & vbTab & "invalid e-mail syntax!" & vbNewLine
        Pass = False
    End If
Next i
' Shows the result
Situacao = IIf(Pass, "All valid", "Not all valid") & vbNewLine & Left(Situacao, Len(Situacao) - 1)
If Not Pass Then txtEmail = temp
MsgBox Situacao & vbNewLine & "Mailing list: " & txtEmail
End Sub

 

[austin350s10]

I Love it!!!

Thats works so good. The results MsgBox is super cool but I am wondering if it could only alert them if there is a incorrect email address entered. If all the email addresses are correct just continue on the the next step. Is thet possible?

Thanks!

 

[VoG]

Yep, those MsgBoxs will become infuriating. I've left one in but you can delete it after testing. This prompts to re-enter invalid emails

Sub email()
Dim txtEmail As String
Dim i As Integer, X
txtEmail = InputBox("Type the addresses separated by ;", "e-mail address")
X = Split(txtEmail, ";")
For i = LBound(X) To UBound(X)
' Check e-mail syntax
    Do Until IsEmailValid(X(i))
        X(i) = InputBox("Re-enter '" & X(i) & "'")
    Loop
Next i
txtEmail = Join(X, ";")
'check
MsgBox txtEmail
End Sub