Flag email going to multiple different external domains using VBA

问题

We are trying to read the domains of addresses an email is being sent to, and if there is more than one domain, confirm that the user wants to send the email. That way we don't risk confidentiality by sending an email to a wrong domain.

We developed a macro that flags all emails being sent to a different domain as external, and gives a popup box that asks "Yes or No". We want to modify to flag only if there is more than one external domain.

For example, flag @google.com, @yahoo.com and not @google.com, @google.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 Address As String
    Dim lLen
    Dim strMyDomain
    Dim internal As Long
    Dim external As Long

    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 internal = 0
        If str1 <> strMyDomain Then external = 1
    Next

    If internal + external = 1 Then
        prompt = "This email is being sent to an External Address. Do you still wish to send?"

        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
        End If
   End If

End Sub
'''

回答1:

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)

dim firstexternaldomain as string

  If str1 = strMyDomain Then internal = 0
  If str1 <> strMyDomain Then 
      if len(firstexternaldomain)=0 then 
          firstexternaldomain = str1
      else
          if str1 = firstexternaldomain then internal = 0 else external = 1    
      end if
  End if
Next

there could be some less complicated parts in your code, but if it works never change it! I hope my suggestion works, Max

来源：https://stackoverflow.com/questions/58457310/flag-email-going-to-multiple-different-external-domains-using-vba

标签

vba

outlook