宛先を連絡先から検索し、会社名のフォルダーに移動するマクロ


コメントにて以下のご要望をいただきました。


はじめてコメントさせていただきます。
私は職員の人数が6人という小さな事務所を経営しているのですが、その客先や社内の連絡ツールとしてOUTLOOKを活用しています。
情報を共有し、円滑に業務を進められるようメールアドレスは原則一つにして、その自社アドレスで客先からのメールを受信し、また、その自社アドレスから客先へ回答メールを発信するとともに、BCCにその自社アドレスを指定することで回答メールの内容を社内で共有しています。
そして受信トレイの下に客先名のフォルダーを作り、受信メールと回答メールを客先別に移動することで管理しています。
これまでは一件ずつマウスを使って移動していたのですが、こちらのサイトでVBAを利用することで自動化ができることを知り、自作したところある程度のところまではでき、腱鞘炎になりかけていた右腕が回復するくらいまで業務が効率化しました。しかし、どうしても越えられない一線ができたので、今回ご質問させていただくことにしました。
越えられない一線というのは、BCCで自社に送られてきた回答メールのことです。私が自作したVBAは、受信トレイの中のメールについて、送信先アドレス(SenderEmailAddressプロパティ)が当社のアドレスだったときは、そのメールの宛先(TOプロパティ)で連絡先の名前(Fullnameプロパティ)を検索して、ヒットした連絡先の会社名(Companynameプロパティ)と同名のフォルダーに移動するという仕様です。
しかし、この中のメールの宛先(TOプロパティ)は、さまざまなパターン(相手がつけた名前、メールアドレス、クオーテーション付名等)があり、いつくかこぼれてしまうものができてしまうのです。宛先(TOプロパティー)にはアドレスも隠れているように思うのですが、これを取得する方法はないのでしょうか?
長文になりましたが、よろしくお願いします。
(環境はwindows8.1、OUTLOOK2013です)



宛先のアドレスなどの詳細な情報は、メールの Recipients コレクションで受信者ごとのプロパティとして取得が可能です。

以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub MoveToCompanyFolderInInbox()
    On Error Resume Next
    Const MY_ADDRESS = "info@example.com" ' 処理すべきメールの差出人アドレス
    Dim fldInbox As Folder
    Dim i As Integer
    Dim objRecip As Recipient
    Dim strCompany As String
    Dim fldCompany As Folder
    '
    Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
    For i = fldInbox.Items.Count To 1 Step -1
        If fldInbox.Items(i).SenderEmailAddress = MY_ADDRESS Then
            For Each objRecip In fldInbox.Items(i).Recipients
                If objRecip.Type = olTo Then
                    strCompany = FindCompanyByAddress(objRecip.Address)
                    If strCompany <> "" Then
                        Set fldCompany = FindSubFolder(fldInbox, strCompany)
                        fldInbox.Items(i).Move fldCompany
                        Exit For
                    End If
                End If
            Next
        End If
    Next
End Sub
'
Private Function FindCompanyByAddress(strAddress As String) As String
    Dim objContacts As Folder
    Dim objContact As ContactItem
    '
    Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
    Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
        & "' or [Email2Address] = '" & strAddress _
        & "' or [Email3Address] = '" & strAddress & "'")
    If objContact Is Nothing Then
        FindCompanyByAddress = ""
    Else
        FindCompanyByAddress = objContact.CompanyName
    End If
End Function
'
Private Function FindSubFolder(fldParent As Folder, strName As String) As Folder
    Dim fldSub As Folder
    For Each fldSub In fldParent.Folders
        If fldSub.Name = strName Then
            Set FindSubFolder = fldSub
            Exit Function
        End If
    Next
    Set FindSubFolder = fldParent.Folders.Add(strName, olFolderInbox)
End Function

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

宛先を連絡先から検索し、会社名のフォルダーに移動するマクロ」への1件のフィードバック

  1. ご回答ありがとうございます。
    早速組み込みんで実行したところ、意図したとおり各フォルダーに移動させることができました。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中