メッセージの差出人を連絡先の表示名に置き換え、さらに連絡先ごとのフォルダに振り分けるマクロ


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

以下のようなマクロで実現できるでしょう。

' ここをトリプルクリックでマクロ全体を選択できます。
'
'  受信時に自動実行されるマクロ
'
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 fldOther 'As Folder
    Dim strFolderName As String
    Dim objContact 'As ContactItem
    ' 連絡先を検索
    Set objContact = FindContactByAddress(objItem.SenderEmailAddress, strFolderName)
    Set fldDest = Nothing
    If Not objContact Is Nothing Then
        ' アドレスで連絡先が見つかったらそのフォルダの名前のフォルダを検索
        For Each fldContact In fldCurrent.Folders
            objItem.SentOnBehalfOfName = objContact.FullName
            objItem.Save
            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
    Else
        For Each fldOther In fldCurrent.Folders
            If fldOther.Name = "その他" Then
                Set fldDest = fldOther
            End If
        Next
        If fldDest Is Nothing Then
            ' 移動先フォルダが見つからなければ連絡先フォルダの名前でフォルダを作成
            Set fldDest = fldCurrent.Folders.Add("その他")
        End If
    End If
    ' 移動先フォルダにメッセージを移動
    objItem.Move fldDest
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

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

広告

メッセージの差出人を連絡先の表示名に置き換え、さらに連絡先ごとのフォルダに振り分けるマクロ」への7件のフィードバック

  1. Application_NewMailExは素晴らしいできです!要望にたいして文句の付け所のないマクロです!ありがとうございました^^

  2. MoveBySender素晴らしいです!!ほぼイメージどおりのものです!ひとつだけ、想像どおりでなかったことがあります。それは、一度分配したメールを再分配したいときがまれにあります。しかし、一度分配されたメールはこのマクロでは再分配されません。無理やり再分配させようと思い、再分配させたいメールを指定した状態でマクロを実行してみると、そのメールのあるフォルダ内に、さらにジャンルをフォルダを作成してしまうのです。したがって、MoveBySenderに「受信トレイの階層フォルダ内に含まれるすべてのメールアイテムを受信トレイに移す」という行程を最初に取り入れては、いただけないでしょうか?

  3. To 0123 さんMoveBySender の前にすべてのメールアイテムを移動して再実行、となると追加するコード量が多くなり、実行時間も長くなります。それに、振り分け済みのメールを元に戻す意味がわかりません。「その他」に移動されたメッセージを、連絡先作成後に改めて移動しなおしたいということであれば、以下のようなロジックでよいでしょうか?・「その他」フォルダを選択して MoveBySender を実行すると、「受信トレイ」の下のフォルダに移動される。

  4. >「その他」フォルダを選択して MoveBySender を実行すると、「受信トレイ」の下のフォルダに移動される。これを実行しましたが、以前行った通り、+受信トレイ|+友達||-鈴木||+学校||+その他 |+友達 ||-佐藤 | |+学校  |-加藤先生のように、その他フォルダ内にメールを分配してしまうのです。これを起こさないようにするために、一度受信トレイに移すという過程があれば、解決されると判断したのですが、たしかにマクロに時間がかかってしまいそうなので、ぼくにはいい案がみつかりません。どうするべきでしょうか??これとは別に、選択したフォルダまたはメールアイテムを一度受信トレイに移す+MoveBySenderのくみあわせのReMoveBySenderという再分配専用マクロを作るというのはどうでしょうか?

  5. 「「その他」フォルダを選択して MoveBySender を実行すると…」というのは変更後のコードロジックを確認するための記述だったのですが…文章で説明しても埒が明かなそうなので、常に受信トレイの下に階層構造を作成するようにコードを変更してみました。今度のコードは「その他」フォルダで MoveBySender を実行しても、受信トレイの下にあるフォルダに移動します。これで要望の動作になるか確認してみてください。

  6. すばらしいマクロですね!ちなみに、一点可能ならばなのですが、
    メッセージの差出人を連絡先の表示名に置き換える、だけのマクロが欲しいのですが・・・
    このマクロの一部分を抜き出せば実現できますでしょうか。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中