Check for different domains macro to be triggered by specific domains only

[Bordan52]

Hi All,

I have been using Diane's "Check for different domains" macro to warn me when I am sending an email to recipients at mutiple domains, and it has been working very well. The only funcionality I would like to add is for the macro to be triggered only when sending emails to specific domains (and give the greenlight to all other outgoing emails, even when sent to multiple domains).

Here is the original macro I am currently using:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.propertyAccessor
Dim prompt As String
Dim strMsg As String
Dim Address As String
Dim lLen
Dim arr
Dim strMyDomain
Dim userAddress
Dim str1
Dim strRecip
Dim i
Dim j
 
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
 
' non-exchange
' userAddress = Session.CurrentUser.Address
' use for exchange accounts
userAddress = Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
lLen = Len(userAddress) - InStrRev(userAddress , "@")
strMyDomain = Right(userAddress, lLen)
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
  
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "@")
str1 = Right(Address, lLen)
If str1 <> strMyDomain Then
strRecip = str1 & "," & strRecip
End If
Next
arr = Split(strRecip, ",")
' need to subtract one because string ends with a ,
For i = LBound(arr) To UBound(arr) - 1
   For j = LBound(arr) To i
    If arr(i) <> arr(j) Then
prompt = "This email is being sent to people at " & arr(i) & " and " & arr(j) & " Do you still wish to send?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
Exit Sub ' stops checking for matches
  
End If
Next j
 
Next
 
End Sub

And here is the version I have been trying to make work to trigger only when sending emails to gmail.com or me.com

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim prompt As String
Dim strMsg As String
Dim Address As String
Dim lLen
Dim arr
Dim strMyDomain
Dim userAddress
Dim str1
Dim strRecip
Dim i
Dim j

Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

' non-exchange
' userAddress = Session.CurrentUser.Address
' use for exchange accounts
userAddress = Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
lLen = Len(userAddress) - InStrRev(userAddress, "@")
strMyDomain = Right(userAddress, lLen)

Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor

Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "@")
str1 = Right(Address, lLen)

Select Case Right(Address, lLen)
Case "me.com", "gmail.com"
strMsg = strMsg & " " & Address & vbNewLine
End Select

If str1 strMyDomain Then
strRecip = str1 & "," & strRecip
End If
Next

arr = Split(strRecip, ",")

' need to subtract one because string ends with a ,
For i = LBound(arr) To UBound(arr) - 1
For j = LBound(arr) To i
If arr(i) arr(j) Then

prompt = "This email is being sent to people at " & arr(i) & " and " & arr(j) & " Do you still wish to send?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
Exit Sub ' stops checking for matches

End If
Next j

Next

End Sub

It does not give me any error messages, but currently it is being triggered for all outgoing emails, and not only for those sent to gmail.com or me.com.

Could you please let me know what should be changed to make this work as intended?

Thank you very much in advance!

 

[Diane Poremsky]

Stick this in the original code between the if and the arr lines. As soon as it finds either me or gmail domain, it moves on to create the warning. If neither address is found in the string, it exits the sub.

if there are a lot of domains you want to be warned about, put the most common ones first so they are tested first - as soon as it finds a match, it'll stop checking.

If str1 <> strMyDomain Then
strRecip = str1 & "," & strRecip
End If
Next

Select Case True
Case InStr(1, strRecip, "me.com")
GoTo warning
Case InStr(1, strRecip, "gmail.com")
GoTo warning
Case Else
Exit Sub
End Select

warning:
arr = Split(strRecip, ",")

 

[Bordan52]

Thank you so much, this is working perfectly!