Outlook VBA代码不适用于所有电子邮件地址

后挖我的一点点找到了解决办法，应该让你指出正确的方向。这是基于怀疑您的问题是由于您的目标用户在您的组织的Exchange服务器中不可用导致的。这个解决方案应该解决这个问题，但如果它不，它至少会让你知道下一步的位置。

首先，我把代码示例从这个MSDN文章（https://msdn.microsoft.com/en-us/VBA/Outlook-VBA/articles/obtain-the-e-mail-address-of-a-recipient），并修改它，让它返回地址用户和他们的电子邮件的数组：

Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" 
Private Function GetSMTPAddressesForRecipients(ByVal MailItem As Outlook.MailItem) As Variant 
    Dim Recipients As Outlook.Recipients 
    Set Recipients = MailItem.Recipients 
    Dim Addresses As Variant 
    ReDim Addresses(0 To Recipients.Count - 1, 0 To 1) 
    Dim Accessor As Outlook.PropertyAccessor 
    Dim Recipient As Outlook.Recipient 
    For Each Recipient In Recipients 
     Set Accessor = Recipient.PropertyAccessor 
     Dim i As Long 
     Addresses(i, 0) = Recipient.Name 
     Addresses(i, 1) = Accessor.GetProperty(PR_SMTP_ADDRESS) 
     i = i + 1 
    Next 
    GetSMTPAddressesForRecipients = Addresses 
End Function 

通过电子邮件中的所有收件人这将循环，并捕获他们的姓名和电子邮件，将每个人放入阵列中的下一个位置。接下来，我们需要在日常工作中使用这些信息：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
    ' Note that I explicitly convert the subject to lowercase since the patterns use lowercase 
    Dim EmailSubject As String 
    EmailSubject = LCase(Item.Subject) 
    If EmailSubject Like "*update*" Or EmailSubject Like "*revision*" Then 
     Dim Addresses As Variant 
     Addresses = GetSMTPAddressesForRecipients(Item) 
     Dim i As Long 
     For i = LBound(Addresses, 1) To UBound(Addresses, 1) 
      If Addresses(i, 1) = "[email protected]" Then 
       MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?" 
       Exit For 
      End If 
     Next 
    End If 
End Sub 

有几件事要注意。首先，您的模式使用的是小写字母，因此您需要将主题转换为小写字母，因此，如果您有像“更新版本”这样的主题，您的模式仍然会捕获该主题。其次，我把最可能的情况放在前面，也就是说，你的大多数电子邮件主题不会包含“主题”或“修订”。然后无需向服务器询问收件人的地址。以前，您的代码会在检查它是否需要它之前获取地址。最好只要求我们需要的东西，它使您的代码更易于阅读和维护，同时还可以降低任何处理成本。

最后，这段代码将循环通过全部地址，而不只是看第一个。通过这样做，即使他是列表中的第二个，第三个或第五十个地址，您仍然会触发警报。

我希望这有助于！以下是完整的代码：

Option Explicit 
Private Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
    ' Note that I explicitly convert the subject to lowercase since the patterns use lowercase 
    Dim EmailSubject As String 
    EmailSubject = LCase(Item.Subject) 
    If EmailSubject Like "*update*" Or EmailSubject Like "*revision*" Then 
     Dim Addresses As Variant 
     Addresses = GetSMTPAddressesForRecipients(Item) 
     Dim i As Long 
     For i = LBound(Addresses, 1) To UBound(Addresses, 1) 
      If Addresses(i, 1) = "[email protected]" Then 
       MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?" 
       Exit For 
      End If 
     Next 
    End If 
End Sub 
Private Function GetSMTPAddressesForRecipients(ByVal MailItem As Outlook.MailItem) As Variant 
    Dim Recipients As Outlook.Recipients 
    Set Recipients = MailItem.Recipients 
    Dim Addresses As Variant 
    ReDim Addresses(0 To Recipients.Count - 1, 0 To 1) 
    Dim Accessor As Outlook.PropertyAccessor 
    Dim Recipient As Outlook.Recipient 
    For Each Recipient In Recipients 
     Set Accessor = Recipient.PropertyAccessor 
     Dim i As Long 
     Addresses(i, 0) = Recipient.Name 
     Addresses(i, 1) = Accessor.GetProperty(PR_SMTP_ADDRESS) 
     i = i + 1 
    Next 
    GetSMTPAddressesForRecipients = Addresses 
End Function