Макрос для Outlook, есть ли способ помечать электронные письма, идущие на несколько разных внешних доменов, с помощью VBA

Question

Мы пытаемся разработать макрос, который будет читать домены пользователей, на которые отправляется электронная почта, и, если существует более одного отдельного домена, пометьте их и подтвердите, что пользователь все еще хочет отправить электронную почту. Таким образом, мы не рискуем конфиденциальностью, отправляя электронное письмо на неправильный домен.

В настоящее время мы разработали макрос, который помечает ВСЕ электронные письма, отправляемые с другого домена, как внешние, и предоставляет всплывающее окно с вопросом «Да или Нет». (Показано ниже) Однако мы хотим изменить его, чтобы вместо ВСЕГДА помечать внешний домен, он помечает внешние домены только в том случае, если их больше 1.

, например, это flags @ google.com, @yahoo.com ... а не @ 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
'''

Answer 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

могут быть некоторые менее сложные части в вашем коде, но если он работает, никогда не меняйте его! Я надеюсь, что мое предложение работает, Макс