使用VBA标记发送到多个不同外部域的电子邮件

我们正在尝试读取电子邮件发送到的地址域，如果有多个域，请确认用户想要发送电子邮件。这样，我们就不会因为向错误的域发送电子邮件而冒保密风险

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

例如，标记@google.com、@yahoo.com而不是@google.com、@google.com

私有子应用程序\u ItemSend（ByVal项作为对象，取消作为布尔值）
将收件人设置为Outlook.Recipients
将recip设置为Outlook.Recipient
将pa设置为Outlook.propertyAccessor
将提示变暗为字符串
作为字符串的Dim地址
迪姆伦
暗结构域
暗内如长
暗淡的外部
常量PR_SMTP_地址作为字符串=”http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
“不交换
'userAddress=Session.CurrentUser.Address
'用于外汇帐户
userAddress=Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
lLen=Len（用户地址）-InStrRev（用户地址“@”）
strMyDomain=Right（用户地址，lLen）
设置recips=Item.Recipients
对于recips中的每个recips
设置pa=recip.propertyAccessor
地址=LCase（pa.GetProperty（PR_SMTP_地址））
lLen=Len（地址）-InStrRev（地址“@”）
str1=右侧（地址，lLen）
如果str1=strMyDomain，则内部=0
如果str1 strMyDomain，则外部=1
下一个
如果内部+外部=1，则
提示符=“此电子邮件正在发送到外部地址。是否仍要发送？”
如果MsgBox（提示，vbYesNo+VBEQUOTION+vbMsgBoxSetForeground，“检查地址”）=vbNo，则
取消=真
如果结束
如果结束
端接头
'''

设置recips=Item.Recipients
对于recips中的每个recips
设置pa=recip.propertyAccessor
地址=LCase（pa.GetProperty（PR_SMTP_地址））
lLen=Len（地址）-InStrRev（地址“@”）
str1=右侧（地址，lLen）
dim firstexternaldomain作为字符串
如果str1=strMyDomain，则内部=0
如果是str1 strMyDomain，则
如果len（firstexternaldomain）=0，则
firstexternaldomain=str1
其他的
如果str1=firstexternaldomain，则内部=0，否则外部=1
如果结束
如果结束
下一个

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

---

Max你能用我的答案吗？有什么意见/问题吗？

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