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 

私はポストするアドレスを変更しましたが、フォーマットと長さは同じです。 IDのアイデアがあれば本当にありがたいです。私たちのサプライヤはテストメールとスパムの絵がいっぱいのメールボックスを持っています。私はあなたが正しい方向に指摘を受ける必要がある解決策を見つけた掘りの少し後

おかげ

Answer 1

。これは、ターゲットユーザーが組織のExchangeサーバー内で利用できないことが原因であるという疑いに基づいています。この解決策はが問題を解決するはずですが、もしそうでなければ、少なくとも次はどこを見なければならないかを知ることになります。

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 

これがループをすべての受信者によってメール内：それはアドレスユーザーとそのメールの配列を返すように

まず、私は、このMSDNの記事（https://msdn.microsoft.com/en-us/VBA/Outlook-VBA/articles/obtain-the-e-mail-address-of-a-recipient）からのコード例を取って、それを修正しましたそれらの名前と電子メールをキャプチャし、それぞれをアレイ内の次の場所に配置します。次に、あなたのルーチン内でこの情報を使用する必要があります：

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 

ここで注意するべきことがいくつかあります。まず、あなたのパターンがサブジェクトに小文字を使用していたので、サブジェクトを小文字に変換して、 "リビジョンを更新"のようなテーマがある場合、パターンはまだそれをキャッチします。

第2に、最も可能性の高い条件を前に付けます。つまり、電子メールの件名のほとんどに「件名」または「改訂」が含まれません。受信者のアドレスをサーバに問い合わせる必要はありません。以前は、コードが必要かどうかを確認する前に、コードがアドレスを取得していました。必要なものだけを尋ねるのが最善で、コードを読みやすくして維持し、処理コストを削減します。

最後に、このコードはすべてののアドレスをループし、最初のアドレスだけではありません。これにより、リストの2番目、3番目、50番目のアドレスであってもアラートがトリガーされます。

こちらがお役に立てば幸いです。完全なコードは次のとおりです。

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