使用VBA将电子邮件转发到多个不同的外部域

Question

我们正在尝试读取电子邮件发送到的地址的域，如果有多个域，请确认用户要发送电子邮件。这样，我们就不会通过将电子邮件发送到错误的域来冒险承担机密性。

我们开发了一个宏，该宏将所有发送到另一个域的电子邮件标记为外部，并提供一个弹出框，询问您“是或否”。我们只想修改为仅在有多个外部域时标记。

例如，标记@ 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

您的代码中可能有一些不太复杂的部分，但是如果可以，请不要更改它！我希望我的建议行得通，最大值