件名にキーワードを含むメールを受信した際に分類項目と連番を付与するマクロ


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


業務効率化のために色々と検討しており現在は
下記をベースに追加でカテゴリーに分けた後に連番をつける方法を探しています。

Outlook 研究所 2012年2月18日
メッセージの受信時に連番を件名に付与するマクロ
カテゴリー: Outlook 2003 マクロ,Outlook 2007 マクロ,Outlook 2010 マクロ,Outlook VBA マクロ — outlooklab @ 12:00 PM
メッセージの受信時に連番を件名に付与するマクロ

【詳細】
上記では、【「特定の言葉を件名に含む」メールまたは「特定の送信者」からのメールのみに】という条件が入っておりますが
この条件を【カテゴリー分けをしたい際に】に変更したいです。
イメージとしては受信トレイ内の最新受信メールに対してカテゴリー赤を選択した場合
カテゴリの色と分けと同時に連番を振り、カテゴリーでソートした際に赤のカテゴリーの最新受信メールが何件目か人目で分かるようにしたいです。
※カテゴリーの色分けをした順番ではなく、受信時間に対して連番を振って欲しい。

その設定を複数のカテゴリー(青、黄色、緑など)に対してどうようにそれぞれ連番を振り分けたいです。


こちら、カテゴリー分けしたときというタイミングでの連番付与が難しいため、受信時にキーワードをもとに分類項目を割り当て、同時に分類項目ごとの連番を設定するというマクロを作成してみました。

マクロは以下のようになります。arrKeyword と arrCategories を適宜変更してご使用ください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 受信時のイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objItem As Variant
    Dim objMail As MailItem
    '
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    If objItem.MessageClass = "IPM.Note" Then
        Set objMail = objItem
        SetCategory objMail
    End If
End Sub
' 分類項目ごとの連番を設定する処理のメイン
Public Sub SetCategory(objMail As MailItem)
    ' 件名に含むキーワードの設定
    Dim arrKeywords As Variant: arrKeywords = Array("Red", "Blue", "Yellow", "Green")
    ' キーワードに対応する分類項目の設定
    Dim arrCategories As Variant: arrCategories = Array("赤", "青", "黄", "緑")
    Dim i As Integer
    Dim iSerial As Integer
    ' 分類項目のキーワードの数だけループ
    For i = LBound(arrKeywords) To UBound(arrKeywords)
        ' 件名にキーワードが含まれていたら
        If InStr(1, objMail.Subject, arrKeywords(i), vbTextCompare) > 0 Then
            ' 連番を取得
            iSerial = GetCategorySerial(arrCategories(i))
            ' 件名に連番を付与
            objMail.Subject = "[" & arrCategories(i) & ":" & iSerial & "]: " & objMail.Subject
            ' 分類項目を設定
            objMail.Categories = arrCategories(i) & ";" & objMail.Categories
            ' アイテムを保存
            objMail.Save
            ' 連番をインクリメント
            iSerial = iSerial + 1
            ' 連番を保存
            SetCategorySerial arrCategories(i), iSerial
        End If
    Next
End Sub
' 分類項目ごとの連番を保存する Storage アイテムの取得
Private Function GetStorageItem() As StorageItem
    Const CATNUM_STORAGE = "IPM.OutlookLab.Categories"
    Dim fldInbox As Folder
    ' 受信トレイから Storage アイテムを取得
    Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
    Set GetStorageItem = fldInbox.GetStorage(CATNUM_STORAGE, olIdentifyByMessageClass)
End Function
' 分類項目ごとの連番を取得する関数
Private Function GetCategorySerial(ByVal strCategory As String) As Integer
    On Error Resume Next
    Dim objStorage As StorageItem
    Dim objProp As UserProperty
    Set objStorage = GetStorageItem()
    ' 分類項目名のユーザー定義フィールドを取得
    Set objProp = objStorage.UserProperties.Item(strCategory)
    GetCategorySerial = objProp.Value
    ' 値が 0 なら設定されていないため、初期値を 1 に設定
    If GetCategorySerial = 0 Then
        GetCategorySerial = 1
    End If
End Function
' 分類項目ごとの連番を設定するプロシージャ
Private Sub SetCategorySerial(ByVal strCategory As String, iSerial As Integer)
    On Error Resume Next
    Dim objStorage As StorageItem
    Dim objProp As UserProperty
    Set objStorage = GetStorageItem()
    ' 分類項目名のユーザー定義フィールドを取得
    Set objProp = objStorage.UserProperties.Item(strCategory)
    ' ユーザー定義フィールドがなければ追加
    If objProp Is Nothing Then
        Set objProp = objStorage.UserProperties.Add(strCategory, olInteger)
    End If
    objProp.Value = iSerial
    objStorage.Save
End Sub

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

広告

件名にキーワードを含むメールを受信した際に分類項目と連番を付与するマクロ」への6件のフィードバック

  1. マクロの作成ありがとうございました。
    大変申し訳ございませんが、本当にまったくの初心者のため可能であれば
    適宜変更する項目に対しての利用方法を教えて下さい。

    「件名に含むキーワードの設定の場合」
    Array(“Red”,,,,の「Red」を希望するキーワードに変更すればいいということでしょうか。
    また「連番を取得」においては
    iSerial = GetCategorySerial(arrCategories(i)) ,,,,の「arrCategories」を
    希望するカテゴリー名に変更すればいいのでしょうか。

    なお、現在使用しているのが英語環境だということを申し忘れてました。
    その場合、漢字がコード内に入力出来ないようなので、該当のキーワードも全て英語での設定が必要との認識でいいでしょうか。

    全くの初心にも関わらず、このような質問を差し上げ申し訳ございません。
    引き続き宜しくお願い致します。

    • はい。
      arrKeywords の “Red” などをキーワードに置き換え、arrCategories の “赤” などを分類項目に置き換えます。
      また、英語環境となると日本語は使えないので、キーワードも分類項目も英語にする必要がありますね。

      • 回答いただきありがとうございました。
        お伝えいただいた方法でマクロを実行することが出来ました。

        なお、もう1点だけ確認させていただいてもいいでしょうか。
        連番のカウントを午前零時を過ぎた時点で
        新しく1からカウントさせることは可能でしょうか?
        もしくは最大で99までとし、100以降は再度1からカウントしだすことは可能でしょうか?

        お手数ですがご確認下さい。

      • 最大を 99 にして 100 以降は 1 から、というのであれば、以下のようにします。

        iSerial = iSerial + 1
        If iSerial > 99 Then iSerial = 1

      • 何度も申し訳ございませんが追加でもう1点ご確認をお願い致します。
        このマクロは個人のInboxだけ適用となり
        共有されているメールboxには適用できないのでしょうか。
        ご確認をお願い致します。

      • このマクロで使用している NewMailEx は自分自身のメールボックスの受信トレイにのみ有効であり、共有メールボックスには適用されません。
        共有メールボックスでの処理が必要となると、実装を変更する必要があります。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中