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

Question

我有一段简短的代码，在我发送电子邮件时运行。它会查看收件人地址和主题以查看它是否包含某些单词，然后弹出消息框提醒我们更新绘图版本控制。它适用于内部电子邮件地址，似乎在某些外部电子邮件地址上工作，但出于某种原因，它不喜欢我实际需要它留意的电子邮件地址。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
Dim hismail As String 
Dim strSubject As String 
strSubject = Item.Subject 

Dim olObj As MailItem 


Set olObj = Application.ActiveInspector.CurrentItem 
hismail = olObj.Recipients.Item(1).AddressEntry.GetExchangeUser.PrimarySmtpAddress 
Set olObj = Nothing 

If hismail = "David@abclimited.net" And strSubject Like "*update*" Or strSubject Like "*revision*" Then 


    MsgBox "Dont forget to update Drawing PDF`s if necessary", vbExclamation, "Have you updated the PDF`s?" 


End If 
End Sub 

我已将地址更改为帖子，但其格式和长度相同。如果任何人有任何想法，我真的很感激它，如我们的供应商谁拥有一个邮箱充满测试电子邮件和垃圾图片。

感谢

Answer 1

后挖我的一点点找到了解决办法，应该让你指出正确的方向。这是基于怀疑您的问题是由于您的目标用户在您的组织的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) = "David@abclimited.net" 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) = "David@abclimited.net" 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