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