Why does this Microsoft Outlook macro prompt me every time I send an email?-CodePudding

I use the macro below to warn me every time I try to send an email outside my company, where external emails are those that don't end in the mycompany.com domain. However, the macro prompts me every time I send an email, regardless of the recipient or recipients. It should only prompt me if at least one of the to/cc/bcc recipients has an email address with a different domain. Why is this happening?

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim i As Long
Dim xRecipientAddress As String
Dim xPrompt As String
Dim xYesNo As Integer
Dim xPos As Integer
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
For i = xRecipients.Count To 1 Step -1
    xRecipientAddress = xRecipients.Item(i).Address
    xPos = InStrRev(LCase(xRecipientAddress), "@mycompany.com")
    If xPos <= 0 Then Exit For
    Cancel = False
Next
If InStrRev(LCase(xRecipientAddress), "@mycompany.com") > 0 Then Exit Sub
xPrompt = "Are you sure you want to send this email outside of The Company?"
xYesNo = MsgBox(xPrompt, vbYesNo   vbQuestion, "External Email Warning")
If xYesNo = vbNo Then Cancel = True
End Sub

CodePudding user response：

The Recipient.Address may not return an SMTP email address in case of Exchange accounts. Microsoft Exchange Server can operate with email address types such as Exchange, SMTP, X.400, Microsoft Mail, etc. By default, the Address property of the Recipient class returns just an Exchange type address, for example this one:

/O=ORGANIZATION_NAME /OU=EXCHANGE_GROUP /CN=RECIPIENTS /CN=USER_NAME

To get other address types, we need to find the recipient in the Outlook address book by using the IAddrBook.ResolveName method, then reach the IMailUser interface with the IAddrBook.OpenEntry method and get the PR_EMS_AB_PROXY_ADDRESSES property. Read more about that in the HowTo: Convert Exchange-based email address into SMTP email address article.

Also you may consider using the AddressEntry property of the Recipient class return an object which represents a person, group, or public folder to which the messaging system can deliver messages. You can check out the AddressEntry.AddressEntryUserType property which returns a constant from the OlAddressEntryUserType enumeration representing the user type of the AddressEntry. In case of Exchange entry you need to use the following sequence of property and method calls:

Recipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress

The ExchangeUser.PrimarySmtpAddress property returns a string representing the primary Simple Mail Transfer Protocol (SMTP) address for the ExchangeUser.

CodePudding user response：

I think this logic is easier to follow. I believe InStr is sufficient.

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim xMailItem As MailItem
Dim xRecipients As Recipients
Dim i As Long

Dim xRecipientAddress As String
Dim xPrompt As String

Dim xYesNo As VbMsgBoxResult
Dim xPos As Long

If Item.Class <> olMail Then Exit Sub

Set xMailItem = Item
Set xRecipients = xMailItem.Recipients

For i = xRecipients.count To 1 Step -1

    xRecipientAddress = xRecipients.Item(i).Address
    Debug.Print xRecipientAddress
    
    ' Use text from internal xRecipientAddress
    xPos = InStr(LCase(xRecipientAddress), "@mycompany.com")
    Debug.Print xPos
    
    If xPos = 0 Then
        xPrompt = "Are you sure you want to send this email outside of The Company?"
        xYesNo = MsgBox(xPrompt, vbYesNo   vbQuestion, "External Email Warning")
        If xYesNo = vbNo Then Cancel = True
        Exit For
    End If
    
Next

End Sub