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

Status
Not open for further replies.

Bordan52

New Member
Outlook version
Email Account
Exchange Server 2007
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:

Code:
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


Code:
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!
 
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, ",")
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
K adding more rules to 'different domains check' macro Outlook VBA and Custom Forms 2
P turn off the default "all day" check box in new calendar items. How? Using Outlook 1
L Help: set flag for sent mail to check if received an answer Outlook VBA and Custom Forms 2
Witzker Outlook 2019 Macro to check Cursor & Focus position Outlook VBA and Custom Forms 8
CWM550 Saving Data: Don't check certain folders Using Outlook 2
Victor.Ayala Automated way to check the option "Show this folder as an email Address Book" Outlook VBA and Custom Forms 2
D Spell check Outlook VBA and Custom Forms 3
L Spell-check dictionary confusion Using Outlook 0
S How to export urls from email to excel and check the status of the url ? Using Outlook 5
N Private check box in table view Using Outlook 0
S Outlook to check for specific text Outlook VBA and Custom Forms 3
C Custom Outlook Form - Populate Information from Radio Button / Check Box Using Outlook 0
O Outlook 2016 This rule will only run when you check your email in Outlook.... Using Outlook 4
A Check for words in subject header before sending email Outlook VBA and Custom Forms 4
R Using "check for duplicates" for existing contacts Using Outlook 2
P Suppress dialog box on email check error? Using Outlook 5
Potty Ash MS Outlook 2010 custom form - validation or formula to request user to check a checkbox Outlook VBA and Custom Forms 16
I Check if sent email has been replied Outlook VBA and Custom Forms 1
R Macro to check file name with outlook address book Outlook VBA and Custom Forms 0
Diane Poremsky Check Contacts before moving them to Hotmail Contacts folder Using Outlook 0
Diane Poremsky Check for missing attachments before sending a message Using Outlook 1
R Outlook 2010 Modify Style "Do not check spelling or grammar" not saving Outlook VBA and Custom Forms 0
K check for sender, follow to my personal adress and delete the sent folder. Outlook VBA and Custom Forms 1
J Send and Receive Button - only check default account? Using Outlook 1
A Check for attachment code not working Outlook VBA and Custom Forms 1
Diane Poremsky Check Message Size Before Sending Using Outlook 0
V Check/convert to emailaddresses Outlook VBA and Custom Forms 11
JorgeDario how to check a MailItem has a digital signature (SMIME) with vba? Outlook VBA and Custom Forms 1
O Unable to check name. Using Outlook 3
R Outlook Custom form check if there an attachment Outlook VBA and Custom Forms 2
L Trying to check for the absence of mail. Outlook VBA and Custom Forms 1
S Check if two organisition is added then i have to give managers passward creteria to send mail Using Outlook 1
Peter H Williams check for new email automaticlly Using Outlook 12
C Unusual Signature & Spell Check Query Using Outlook 1
M Calendar navigation displays previous field records.check calendar is shared.. Using Outlook 3
A Can Rule Check Category Contact is assigned? Using Outlook 1
T Outlook 2007 forms: Check boxes and free text boxes not retaining data Using Outlook 1
L check if send message appears in SendItems forder before moving Using Outlook 0
C Create a rule to only check new content in email - disregard original content Using Outlook 3
M Outlook Rules check for new line character Using Outlook 1
G Outlook rule check for messages not received Outlook VBA and Custom Forms 2
E Outlook could not create the work file. Check the temp environment variable Using Outlook 8
B Custom real time, time format check Outlook VBA and Custom Forms 1
B BCM shuts down everytime I try to import/export or check for error BCM (Business Contact Manager) 10
D Check whether mail item is proper for sending or not Outlook VBA and Custom Forms 5
P Check for the distribution list existence Outlook VBA and Custom Forms 1
H out to check whether outlook configured or not Outlook VBA and Custom Forms 1
M Check Profile info Outlook VBA and Custom Forms 1
L Check sent email and reply if have specific words Outlook VBA and Custom Forms 2
Z Check if email was sent Outlook VBA and Custom Forms 1

Similar threads

Back
Top