【Outlook/VBA】メール受信時に相手の宛先別で処理を行う

Excel/VBA

2022.02.09

一つのアドレスが複数のメーリングリストに属してて、受信時の挙動をそれぞれのアドレス毎に分けたい。そんな時の処理。

やりたい事
以下コピッペで利用可能
まとめ

やりたい事

自分のアドレスはhoge@hoge.comとして、XXX@xxx.comとYYY@yyy.comとZZZ@zzz.comと複数メーリングリストに属している状態。
A社はXXX@xxx.comのメーリングリストに送って来て、B社はYYY@yyy.comに送ってくるので、
相手の宛先別で、共有フォルダにフォルダを分けて添付ファイルの保存を行いたいってのが今回やりたい。

以下コピッペで利用可能

Option Explicit
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim recip As Outlook.Recipient

    For Each recip In GetNamespace("MAPI").GetItemFromID(EntryIDCollection).Recipients
       ' 相手の宛先別
       Select Case recip.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
       
          Case "XXX@xxx.com"
                  FileUplode ("\\192.168.100.100\共有フォルダ\XXX\")
          Case "YYY@yyy.com"
                  FileUplode ("\\192.168.100.100\共有フォルダ\YYY\")
          Case "ZZZ@zzz.com"
                  FileUplode ("\\192.168.100.100\共有フォルダ\ZZZ\")
          Case Else

       End Select

    Next

End Sub


Private Function FileUplode(strAddress As String)

    Dim nCnt As Long
    Dim objId As Object
    
    ' 受信トレイ指定　サブフォルダ指定の場合は.Foldersで指定
    For Each objId In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
       ' 未読の場合
       If objId.UnRead = True Then
          For nCnt = 1 To objId.Attachments.Count
             ' PDFが添付されている場合
             If InStr(objId.Attachments.Item(nCnt), ".pdf") Then
                ' 引数のアドレスへ添付を保存
                objId.Attachments.Item(nCnt).SaveAsFile strAddress & objId.Attachments.Item(nCnt)
                ' 既読にする
                objId.UnRead = False
             End If
          Next
       End If
    Next
    
End Function