メッセージを連絡先ごとのフォルダに振り分けるマクロ


コメントで以下のようなご要望をいただきました。


outlookアドレス帳の「連絡先」・「学校」・「友達」などのフォルダ「A(i=1 to ?)」から
すべてのアドレス「B(j=1 to ?)」と名前「C(j=1 to ?)」を認識させ、
受信トレイの中に「A(i)」というフォルダを作成し、
アドレス「B」からのメールが入るような「C(j)」というフォルダを作成するマクロです。
…中略…
*手作業では
登録→ジャンル分けフォルダ作成→その人専用フォルダ作成→仕分け機能により分配
デメリット
100人登録するなどの作業は大変。
従ってマクロでこれをおこなっていただきたいのです。


以下のようなマクロでご要望の動作になるでしょう。
下記のマクロでは Application_NewMailEx により受信時に振り分けの処理を行います。また、MoveBySender マクロを実行すると任意のタイミングで振り分けの処理ができます。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim i As Integer
    Dim c As Integer
    Dim colID As Variant

    If InStr(EntryIDCollection, ",") = 0 Then
        MoveOneItemBySender Session.GetItemFromID(EntryIDCollection), Session.GetDefaultFolder(olFolderInbox)
    Else
        colID = Split(EntryIDCollection, ",")
        For i = LBound(colID) To UBound(colID)
            MoveOneItemBySender Session.GetItemFromID(colID(i)), Session.GetDefaultFolder(olFolderInbox)
        Next
    End If
End Sub

Public Sub MoveBySender()
    Dim i As Integer
    Dim fldCurrent 'As Folder
    Dim objItem 'As MailItem

    Set fldCurrent = ActiveExplorer.CurrentFolder
    For i = fldCurrent.Items.Count To 1 Step -1
        ' メッセージを取得
        Set objItem = fldCurrent.Items(i)
        MoveOneItemBySender objItem, fldCurrent
    Next
End Sub

Private Sub MoveOneItemBySender(objItem As Variant, fldCurrent As Variant)
    Dim fldContact 'As Folder
    Dim fldSender 'As Folder
    Dim fldDest 'As Folder
    Dim strFolderName As String
    Dim objContact 'As ContactItem

    ' 連絡先を検索
    Set objContact = FindContactByAddress(objItem.SenderEmailAddress, strFolderName)
    If Not objContact Is Nothing Then
        ' アドレスで連絡先が見つかったらそのフォルダの名前のフォルダを検索
        Set fldDest = Nothing
        For Each fldContact In fldCurrent.Folders
            If fldContact.Name = strFolderName Then
                ' 連絡先フォルダと同じ名前のフォルダが見つかったらサブフォルダを検索
                For Each fldSender In fldContact.Folders
                    If fldSender.Name = objContact.FullName Then
                        ' 連絡先のフルネームと同じ名前のフォルダが見つかったら移動先に指定
                        Set fldDest = fldSender
                    End If
                Next
                If fldDest Is Nothing Then
                    ' 移動先フォルダが見つからなければ連絡先のフルネームでフォルダを作成し、
                    ' 移動先フォルダとして指定
                    Set fldDest = fldContact.Folders.Add(objContact.FullName)
                End If
            End If
        Next
        If fldDest Is Nothing Then
            ' 移動先フォルダが見つからなければ連絡先フォルダの名前でフォルダを作成
            Set fldContact = fldCurrent.Folders.Add(strFolderName)
            ' さらに連絡先のフルネームでフォルダを作成し、移動先フォルダとして指定
            Set fldDest = fldContact.Folders.Add(objContact.FullName)
        End If
        ' 移動先フォルダにメッセージを移動
        objItem.Move fldDest
    End If
End Sub 

Private Function FindContactByAddress(strAddress As String, ByRef strFolderName As String)
    Dim objContacts 'As Folder
    Dim objContact 'As ContactItem
    Dim objSubFolder ' As Folder
    ' 既定の連絡先フォルダを取得
    Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
    ' 現在のフォルダ名を保存
    strFolderName = objContacts.Name
    ' 連絡先フォルダ内でアドレスを検索
    Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
        & "' or [Email2Address] = '" & strAddress _
        & "' or [Email3Address] = '" & strAddress & "'")
    If objContact Is Nothing Then
        ' 見つからなければサブフォルダを検索
        For Each objSubFolder In objContacts.Folders
            ' 現在のフォルダ名を保存
            strFolderName = objSubFolder.Name
            ' 現在のフォルダ内でアドレスを検索
            Set objContact = objSubFolder.Items.Find("[Email1Address] = '" & strAddress _
                & "' or [Email2Address] = '" & strAddress _
                & "' or [Email3Address] = '" & strAddress & "'")
            ' 見つかったらループを終了
            If Not objContact Is Nothing Then
                Exit For
            End If
        Next
    End If
    Set FindContactByAddress = objContact
End Function  

マクロの登録方法やメニューへの追加について

メッセージを連絡先ごとのフォルダに振り分けるマクロ」への1件のフィードバック

  1. […] コメントで、「メッセージを連絡先ごとのフォルダに振り分けるマクロ」について、さらに差出人の名前を連絡先の名前に置き換えた上で、連絡先ごとのフォルダに振り分けし、連絡先に登録されていない送信者のメールについては「その他」というフォルダに振り分けるようなマクロの要望をいただきました。 […]

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中