Outlook Macro warning when an email is being sent to multiple unintended recipients.

I had this question after viewing Outlook Macro warning when email is being sent to unintended recipients.

Can anyone tell me how to change this code to check for more than one email address?  This works great, but I can't figure out how to add a 2nd email address for it to check.
Thanks.
jpiletAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Bill PrewIT / Software Engineering ConsultantCommented:
Give this a try.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    'On the next line edit the address as desired.  Please enter it in all lowercase.'
    Const ADDRS_TO_WATCH_FOR = "someone1@company.com,someone2@company.com"
    Dim olkRec As Outlook.Recipient
    If Item.Class = olMail Then
        For Each olkRec In Item.Recipients
            If ExistsInList(olkRec.Address, ADDRS_TO_WATCH_FOR) Then
                If MsgBox("This message is addressed to " & ADDRS_TO_WATCH_FOR & ".  Are you sure you want to send it?", vbQuestion + vbYesNo, "Confirm Send") = vbNo Then
                    Cancel = True
                End If
                Exit For
            End If
        Next
    End If
    Set olkRec = Nothing
End Sub

Private Function ExistsInList(strItem, strList) As Boolean
    ExistsInList = False
    If strItem = "" Or strList = "" Then
        Exit Function
    End If
    For Each strElement In Split(strList, ",")
        If LCase(strItem) = LCase(strElement) Then
            ExistsInList = True
            Exit Function
        End If
    Next
End Function

Open in new window


»bp
Bill PrewIT / Software Engineering ConsultantCommented:
Actually, this might work a little better, since you want to show the email that matched.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    'On the next line edit the address as desired.  Please enter it in all lowercase.'
    Const ADDRS_TO_WATCH_FOR = "someone1@company.com,someone2@company.com"
    Dim olkRec As Outlook.Recipient
    Dim strMatch As String
    If Item.Class = olMail Then
        For Each olkRec In Item.Recipients
            strMatch = FindInList(olkRec.Address, ADDRS_TO_WATCH_FOR)
            If strMatch <> "" Then
                If MsgBox("This message is addressed to " & strMatch & ".  Are you sure you want to send it?", vbQuestion + vbYesNo, "Confirm Send") = vbNo Then
                    Cancel = True
                End If
                Exit For
            End If
        Next
    End If
    Set olkRec = Nothing
End Sub

Private Function FindInList(strItem, strList) As String
    Dim strElement As String
    FindInList = ""
    If strItem = "" Or strList = "" Then
        Exit Function
    End If
    For Each strElement In Split(strList, ",")
        If LCase(strItem) = LCase(strElement) Then
            FindInList = strElement
            Exit Function
        End If
    Next
End Function

Open in new window


»bp
jpiletAuthor Commented:
The first one worked, but I was just about to post what you mentioned, it didn't tell me what address in particular i was sending it to.

The second one I get a Compile Error:  For Each control variable must be Variant or Object.
This is on the beginning under the End Sub on the line:

Private Function FindInList(strItem, strList) As String
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Bill PrewIT / Software Engineering ConsultantCommented:
Sorry, corrected.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    'On the next line edit the address as desired.  Please enter it in all lowercase.'
    Const ADDRS_TO_WATCH_FOR = "someone1@company.com,someone2@company.com"
    Dim olkRec As Outlook.Recipient
    Dim strMatch As String
    If Item.Class = olMail Then
        For Each olkRec In Item.Recipients
            strMatch = FindInList(olkRec.Address, ADDRS_TO_WATCH_FOR)
            If strMatch <> "" Then
                If MsgBox("This message is addressed to " & strMatch & ".  Are you sure you want to send it?", vbQuestion + vbYesNo, "Confirm Send") = vbNo Then
                    Cancel = True
                End If
                Exit For
            End If
        Next
    End If
    Set olkRec = Nothing
End Sub

Private Function FindInList(strItem, strList) As String
    Dim strElement As Variant
    FindInList = ""
    If strItem = "" Or strList = "" Then
        Exit Function
    End If
    For Each strElement In Split(strList, ",")
        If LCase(strItem) = LCase(strElement) Then
            FindInList = strElement
            Exit Function
        End If
    Next
End Function

Open in new window


»bp
jpiletAuthor Commented:
Yep, that's the ticket, awesome.  

Let me ask your thoughts on something else.  The issue we have is we have 2 people with the same first name, and their last name is different, but the first 4 letters are the same of the last name.

Could this be modified to instead of returning the email address, it would return a specified name or text?

For example, let's say the 2 email addresses I use are jmiller@email.com and jmilton@email.com for Jim Miller and Jim Milton.

When it checks, it would return, "Are you sure you want to send this to JIM MILLER?"  or
"Are you sure you want to send this to JIM MILTON?"

So it's a little more eye catching?

Additionally, I might edit the text to say "JIM MILLER with So and SO company".
Bill PrewIT / Software Engineering ConsultantCommented:
That's doable, but would take a bit more work, probably double to triple the code so far.  To do that you would probably want to look the email address up in the local Contacts, and if not found perhaps in the Global Address List (assuming you are in an Exchange environment).

Or, if this list is pretty static and you just want to hard code the friendly names in the existing script, nothing fancy, that we could do pretty easy.


»bp
jpiletAuthor Commented:
Yes Sir, this list is very static.  I'm only worried about 2 email address and hard coding the friendly names, or like I added to my previous comment, adding to the friendly static name with something more expansive like "Jim Miller with Miller & Associates" so there would be no way they could misread it.   :)
Bill PrewIT / Software Engineering ConsultantCommented:
Okay, see if you understand this, and it works for you.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    'On the next line edit the address as desired.  Please enter it in all lowercase.'
    Dim arrWarnList()
    arrWarnList = Array(Array("pward@company.com", "Pamela Ward"), _
                        Array("jwatson@company.com", "Justin Watson"), _
                        Array("rbennett@company.com", "Richard Bennett"))

    Dim olkRec As Outlook.Recipient
    Dim strMatch As String
    If Item.Class = olMail Then
        For Each olkRec In Item.Recipients
            strMatch = FindInList(olkRec.Address, arrWarnList)
            If strMatch <> "" Then
                If MsgBox("This message is addressed to " & strMatch & ".  Are you sure you want to send it?", vbQuestion + vbYesNo, "Confirm Send") = vbNo Then
                    Cancel = True
                End If
                Exit For
            End If
        Next
    End If
    Set olkRec = Nothing
End Sub

Private Function FindInList(strItem As String, arrList()) As String
    Dim strElement As Variant
    FindInList = ""
    If strItem = "" Then
        Exit Function
    End If
    For Each arrElement In arrList
        If LCase(strItem) = LCase(arrElement(0)) Then
            FindInList = arrElement(1)
            Exit Function
        End If
    Next
End Function

Open in new window


»bp

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
jpiletAuthor Commented:
Woooo that works beautifully!  Thanks so much for your time and most importantly, that beautiful brain!
jpiletAuthor Commented:
Incredible solution, more than I ever expected I'd get.  Thanks so much!
Bill PrewIT / Software Engineering ConsultantCommented:
Great, and I'd be remiss if I didn't add at least a few comments for posterity...

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim olkRec As Outlook.Recipient
    Dim strMatch As String
    Dim arrWarnList()
    
    ' Array or email addresses to warn when sending to, with "friendly name" to display here
    arrWarnList = Array(Array("pward@company.com", "Pamela Ward"), _
                        Array("jwatson@company.com", "Justin Watson"), _
                        Array("rbennett@company.com", "Richard Bennett"))

    ' Make sure we have an email item
    If Item.Class = olMail Then
        ' Check each of the recipients
        For Each olkRec In Item.Recipients
            ' Check the list of emails to warn when sending to, put up wanring message for confirmation
            strMatch = FindInList(olkRec.Address, arrWarnList)
            If strMatch <> "" Then
                If MsgBox("This message is addressed to " & strMatch & ".  Are you sure you want to send it?", vbQuestion + vbYesNo, "Confirm Send") = vbNo Then
                    Cancel = True
                End If
                Exit For
            End If
        Next
    End If
    Set olkRec = Nothing
End Sub

Private Function FindInList(strItem As String, arrList()) As String
' Look for an email address in an array of addresses
' Each element of the array passed in itself a two elelement array,
' with the first element being the key (email address),
' and the second elelement being the returned data (friendly name)
    Dim strElement As Variant
    FindInList = ""
    If strItem = "" Then
        Exit Function
    End If
    For Each arrElement In arrList
        If LCase(strItem) = LCase(arrElement(0)) Then
            FindInList = arrElement(1)
            Exit Function
        End If
    Next
End Function

Open in new window


»bp
jpiletAuthor Commented:
One last comment, this check it does against the email address isn't case sensitive is it?
Bill PrewIT / Software Engineering ConsultantCommented:
No, it is not case sensitive, notice this line in the function, it converts both the email address from the outgoing email, and the email addresses in the list of exceptions to lower case before comparing them, making it a case insensitive compare.

If LCase(strItem) = LCase(arrElement(0)) Then


»bp
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.