連絡先に登録されている差出人ごとのフォルダに移動するルールを作成するマクロ


コメントにて連絡先フォルダの階層と同じ階層構造で受信トレイにフォルダを作り、差出人によってそのフォルダに移動するルールを作成するマクロがほしいというご要望をいただきました。
具体的には以下のような動作をするマクロです。

  • 連絡先フォルダの階層を維持した形で差出人によりフォルダの振り分けをするルールをマクロで作成する。
  • 一度ルールを作成した連絡先ではルールは再作成しない。
  • 連絡先フォルダにあるすべての連絡先アイテムに対して対応するフォルダを事前にマクロで作成する。(ルールを作るためにはあらかじめフォルダを作る必要があるため)
  • 一つの連絡先アイテムに複数のアドレスが存在する場合、どのアドレスからのメールも一つのフォルダに振り分ける。
  • ルールは連絡先フォルダおよびそのサブフォルダのすべてのアイテムに対し個別に作成される。(たとえば、サブフォルダなども合わせて100個の連絡先があった場合、ルールも100個作られる)

マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
'  ルールを作成していないアイテムを検索
'
Public Sub CreateRuleMoveBySender()
    Dim objStore As Store
    Dim objRules As Rules
    Dim fldContacts As Folder
    Dim fldGroup As Folder
    Dim colContacts As Items
    Dim objItem As Variant
    Dim objContact As ContactItem
    Dim propHasRule As UserProperty
    ' 受信トレイを取得
    Set objStore = Session.GetDefaultFolder(olFolderInbox).Store
    ' ルールを取得
    Set objRules = objStore.GetRules()
    ' 既定の連絡先フォルダを取得
    Set fldContacts = Session.GetDefaultFolder(olFolderContacts)
    ' 連絡先のサブフォルダごとの処理
    For Each fldGroup In fldContacts.Folders
        ' サブフォルダのアイテムごとの処理
        For Each objItem In fldGroup.Items
            ' アイテムが連絡先アイテムだったら
            If objItem.MessageClass = "IPM.Contact" Then
                Set objContact = objItem
                ' ルール作成済みフラグを取得
                Set propHasRule = objContact.UserProperties.Find("ルール作成済み")
                ' ルール作成済みフラグが設定されていなければ
                If propHasRule Is Nothing Then
                    ' ルール作成済みフラグをアイテムに追加
                    Set propHasRule = objContact.UserProperties.Add("ルール作成済み", olYesNo, True)
                    ' ルールを作成
                    CreateRuleFor objContact, objRules
                Else
                    If propHasRule.Value = False Then
                        ' ルール作成済みフラグが False ならルールを作成
                        CreateRuleFor objContact, objRules
                    End If
                End If
                ' ルール作成済みフラグを設定
                propHasRule.Value = True
                ' 連絡先アイテムを保存
                objContact.Save
            End If
        Next
    Next
    objRules.Save
End Sub
'
'  連絡先アイテムごとのルールを作成する
'
Private Sub CreateRuleFor(objContact As ContactItem, objRules As Rules)
    Dim fldContact As Folder
    Dim newRule As Rule
    Dim newCondition As ToOrFromRuleCondition
    Dim newMoveAction As MoveOrCopyRuleAction
    If objContact.Email1Address = "" And objContact.Email2Address = "" And objContact.Email3Address = "" Then
        ' メールアドレスが設定されていない連絡先はルールを作成しない
        Exit Sub
    End If
    ' 新規ルールを作成
    Set newRule = objRules.Create(objContact.FullName, olRuleReceive)
    ' 条件として差出人を使用
    Set newCondition = newRule.Conditions.From
    With newCondition
        .Enabled = True
        ' 差出人の条件にアドレスを設定
        If objContact.Email1Address <> "" Then
            .Recipients.Add (objContact.Email1Address)
        End If
        If objContact.Email2Address <> "" Then
            .Recipients.Add (objContact.Email2Address)
        End If
        If objContact.Email3Address <> "" Then
            .Recipients.Add (objContact.Email3Address)
        End If
        .Recipients.ResolveAll
    End With
    ' アクションとしてフォルダ移動を使用
    Set newMoveAction = newRule.Actions.MoveToFolder
    ' 移動先のフォルダを作成
    Set fldContact = CreateFolderFor(objContact)
    With newMoveAction
        .Enabled = True
        ' 移動先のフォルダを指定
        .Folder = fldContact
    End With
End Sub
'
'  連絡先アイテムごとのフォルダを作成する
'
Private Function CreateFolderFor(objContact As ContactItem) As Folder
    Dim fldInbox As Folder
    Dim fldGroup As Folder
    Dim fldContact As Folder
    ' 受信トレイを取得
    Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
    ' 連絡先アイテムが保存されているフォルダと同じ名前のフォルダを検索
    For Each fldGroup In fldInbox.Folders
        If fldGroup.Name = objContact.Parent.Name Then
            Exit For
        End If
    Next
    ' 同じ名前のフォルダがなければ作成
    If fldGroup Is Nothing Then
        Set fldGroup = fldInbox.Folders.Add(objContact.Parent.Name)
    End If
    ' 連絡先のフルネームでフォルダを検索
    For Each fldContact In fldGroup.Folders
        If fldContact.Name = objContact.FullName Then
            ' 同じ名前のフォルダがあったら新規作成はしない
            Set CreateFolderFor = fldContact
            Exit Function
        End If
    Next
    ' 同じ名前のフォルダがなければ作成
    Set CreateFolderFor = fldGroup.Folders.Add(objContact.FullName)
End Function

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

広告

連絡先に登録されている差出人ごとのフォルダに移動するルールを作成するマクロ」への17件のフィードバック

  1. 今実行してみたところ
    「このストアではルールがサポートされていません。処理を完了出来ませんでした。」とのことでした。
    デバッグしてみると
    Public Sub CreateRuleMoveBySender()関数の
    「Set objRules = objStore.GetRules()」で問題が会ったみたいです。

    最初にいい忘れたのですが、こちらはoffice2010の環境です。
    どうか解決してくださると幸いです。

    • IMAP4 をお使いでしょうか?
      その場合は確かにこちらのコードではエラーとなるようですが。
      もし、IMAP4 だとして、移動先のフォルダは IMAP4 サーバー上の受信トレイの下でしょうか?
      それとも、ローカル フォルダの受信トレイの下でしょうか?

      • IMAP4かどうかはわかりませんが、
        GmailでIMAPアクセスを有効にしてそれをOutlook2010で受信しています。

      • Gmail の IMAP アクセスを使っているということは、IMAP4 を使っているということです。(IMAP4 というのは IMAP のバージョン 4 のことで、現在一般的に使われている IMAP のバージョンは 4 です。)

        下記の通り修正して回避できるか試してみてください。
        修正前:
        Set objStore = Session.GetDefaultFolder(olFolderInbox).Store
        修正後:
        Set objStore = Session.Accounts(1).DeliveryStore

  2. ありがとうございました!
    マクロは実行されました。
    もうひとつ私的問題なのかしれませんが、問題が発生しました(していた?かもしれません)

    規定のデータファイル”Outlook Date File”には電子メール設定がされておらず(できないのでしょうか?)、
    電子メールGmailの設定すると、新たにデータファイルが作成され、それは規定にできません。(そういうものなのでしょうか・・・)
    そのせいか、Outlook起動後画面には
    +Outllok Date File
    +私のGmailアドレス@gamil.com
    の2つのデータファイル名が表示され、ご存知の通りの「受信トレイ」や「下書き」などの階層があります。
    上記マクロは規定の「+Outllok Date File」内の受信トレイについて実行されたためか思い通りの階層が実行されました。
    しかし、Gmailのメールは「+私のGmailアドレス@gamil.com」に受信されており、そちらにはマクロが実行されいないため、そのまま受信トレイに入っています。これではマクロを作成していただいた意味がありません。

    そもそも規定データファイルには電子メールを設定できないのでしょうか?だとしたら受信トレイが用意されてる意味がわかりません
    未熟者の勝手な見解としては
    ①規定データファイルに電子メール設定を行う
    ②「+私のGmailアドレス@gamil.com」でマクロを実行させる
    このどちらかを解決していただきたい(できればどっちともに解説していただきたい)のですが、どうすればいいでしょう・・

    • まず、今回作成したマクロはルールを作成するマクロであり、既存のメールを移動するマクロではありません。(マクロで移動するのではなく、ルールで移動したい、というのがご要望ではなかったのでしょうか?)
      そのため、マクロを実行するとフォルダは作成されますが、メールの移動はこれから受信するメールのみで実施されます。
      受信済みのメールを移動したいのであれば、ルールを手動実行してください。

      また、Gmail が使用している IMAP を Outlook で使う場合、IMAP のフォルダのほうには予定や仕事といった特別なフォルダを作成することができないため、これらのフォルダを使用するために既定のデータファイルが作成されます。既定のデータファイルは POP というプロトコルでは使用可能ですが、IMAP では配信先に指定できません。

      したがって、1 については、Gmail で IMAP をやめて POP 接続にすれば可能です。
      2 については、前述のとおり、ルールを手動実行すれば可能です。

    • すみませんでした・・
      質問の仕方が悪かったようです。

      実際にGmailをpop3にし、outlookで新規に電子メール設定し、自分のアドレスを登録した後、マクロ実行しました。
      やはり規定とは別にデータファイルが作成されました
      また、+Outllok Date File内の受信トレイではフォルダ作成されましたが
      +私のGmailアドレス@gamil.com(pop3)内の受信トレイにはフォルダ作成されませんでした。

      メールを新たに受信しても +私のGmailアドレス@gamil.com(pop3)受信トレイのみ行くため
      メールは+Outllok Date Fileには受信されず、ルールは+Outllok Date File内でのみ設定されているので、
      理想の階層はできないためにそこへ移動することはありませんでした

      この場合どうすればいいのでしょうか?

      • おかしいですね。マクロで勝手にデータファイルは作成しないはずですが。
        IMAP のアカウントがあるプロファイルで POP3 も追加したのでしょうか?
        マクロは二つ以上のアカウントがあることは想定していないので、その場合どのように動作するかわかりません。

        ちょっと話を整理しましょう。
        まず、このマクロはルールを作成するものであり、メールを直ちに移動するものではない、ということはご理解いただけていると思います。
        そして、IMAP を使う場合、移動先は IMAP サーバー上のフォルダではなく既定のデータファイルになります。これが問題なのでしょうか?
        また、IMAP 環境ではマクロで作成されたルールは既定の受信トレイではなく IMAP の受信トレイで動作するはずなのですが、ルールが動作しないのでしょうか?

        ルールを設定するということと、フォルダを作成するということは全く別です。
        フォルダが作成された受信トレイでルールが実行されるというわけではありません。
        わかりづらいということであれば、POP3 のアカウントを削除し、コードを以下のとおり変更してください。

        変更前:
        Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
        変更後:
        Set fldInbox = Session.Accounts(1).DeliveryStore.GetDefaultFolder(olFolderInbox)

  3. あれからいろいろあって、とりあえず
    Gmail(pop3)のデータファイルを規定にすることができました。(ややこしくしてしまって申し訳ございませんでした)
    しかしマクロを実行してもなにもおきません。もちろんアドレス帳アイテムも規定データファイル内のものです。
    (今まで実行したと勘違いしていました。以前紹介を受けたマクロを実行してフォルダを作成したフォルダを、今回あらたに作成したフォルダとおもってしまったようです)
    ということで、受信トレイ内にフォルダ作成すらされていません。

    • 一度マクロを実行すると、マクロで処理済みの連絡先にはフラグが設定されるので、それ以降何度実行しても同じ連絡先にはルールもフォルダも作られません。
      一時的に、以下のコードを変更して実行してみてください。
      変更前:
      If propHasRule.Value = False Then
      変更後:
      If propHasRule.Value = True Then

      実行してうまくいったら、変更前のコードに戻すことをお忘れなく。

  4. こんにちは。
    今年もいろいろお世話になりました。
    Outlook面白いですよね。
    もっともっと使いこなせるように楽しんでみたいと思います。
    来年もよろしくお願いします。

  5. 出来ました!!!
    ありがとうございました

    いろいろと迷惑かけましたが、すべて解決いたしました
    ほんとうにありがとうございました

  6. またまた質問およびお願いなのですが・
    こちらのマクロにさらに以下の機能を追加するよう編集していただきたいのです(本当にかってな要望でもうしわけございません)
    ・連絡先アイテム内のアドレスが変わった際にそのアイテムに関するルールだけを再構成する
    ・連絡祭アイテムが削除された場合にそのアイテムに関するルールを削除する
    一般的な言葉で言いますと 「同期」してほしい といったところでしょうか。
    勝手な要望ですがよろしくお願いします

    • 残念ながら、同期させるのは非常に困難です。
      まず、変更があったかどうかというのを判断することが難しいというのがあります。
      それと、連絡先とルールの関連付けを現在のマクロでは想定していないので、仮に変更があった連絡先を検出できたとしても、その連絡先に関するルールを再構成したり削除したりということはできません。
      同期を考えるとなると、マクロを一から作り直さなければなりませんし、現在のものよりはるかに複雑なものとなります。
      申し訳ないのですが、連絡先を変更したら対応するルールの変更や削除は手作業でお願いできませんでしょうか?

  7. わかりました
    無理を言って申し訳ございません。

    最後に、この高度なマクロをどのようにして勉強したのでしょうか?
    wordVBAやエクセルVBAなどは紹介ページが多いのでなにかと勉強しやすいのですが、OutlookVBAの紹介サイトはわずかしかありません。

    • 私は MSDN を参照したり、自分でいろいろ試したりして勉強しています。
      Outlook は Word や Excel のように操作をマクロ化することができないので、Outlook のオブジェクト モデルを熟知することが必要になりますね。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中