コメントにて以下のご要望をいただきました。
「特定の分類項目にマークしたInboxメールのメールアドレスによるフォルダーへの仕分け」
種々VBA情報のご提供本当にありがとうございます。題記につきお伺いします。
(初心者で、自前で作成を試みていますがつまずいてます。)
現状、この作業はOutlook標準の仕分けルールを使って作業していますが、仕分け
に登録できる項目に容量制限があり、追加登録が出来なくなりました。
VBAコードをお教えいただけますと大変幸甚です。
—
ありがとうございます。ご理解のとおり、「差出人のメールアドレスによるフォルダーの仕分け」が希望です。ただし、仕分けるのは分類項目で「処理完了」のフラグを立てたもののみとし、そうでない場合はルールがヒットしても受信トレイに残すことを希望します
すでにOutlookの仕訳ルールで400件以上のルールを設定しましたが、それらはそのまま残し、登録しきれなかった追加仕訳分のみサブルール的にVBA処理を行うことを希望します。
（本当はOutlookで、仕訳も含む記録領域を増やすことが好ましい方向であろうことは理解します。)
よろしくお願いいたします。
以下のようなフォーマットの CSV ファイルを読み込み、特定の分類項目が設定されているメールについて CSV ファイルの内容に基づいて移動するマクロを作りました。
フォルダー名,アドレス
Folder1,user1@example.com
Folder2,user2@example.com;user3@example.com
フォルダーは受信トレイのサブフォルダーとして存在するものと仮定しています。
また、複数の差出人を同じフォルダーに振り分ける場合は、; で区切って指定することでルールを 1 行にまとめられるようにしました。
このマクロのポイントは Dictionary オブジェクトを使ったことにあります。
Dictionary オブジェクトは VBA の組み込み機能ですが、これを使うと任意の文字列または数字のキーとペアとなるアイテムのデータが扱えるようになり、メールアドレスごとの振り分け先のフォルダーの検索というような処理が非常に簡単になります。
マクロは以下の通りです。
' 特定の分類項目が設定されているアイテムを CSV に従って移動するマクロ
Public Sub MoveItemsBySenderInCSV()
' 移動対象となる分類項目の設定
Const MOVE_MARK = "処理完了"
Dim dicRules As Object
Dim fldInbox As Folder
Dim i As Integer
Dim objItem As Object
Dim strAddr As String
Dim strFolder As String
Dim fldDest As Folder
' CSV ファイルの内容を Dictionary に読み込み
Set dicRules = CreateObject("Scripting.Dictionary")
ImportRulesFromCSV dicRules
' 受信トレイを取得
Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
' 受信トレイのアイテムを最後から確認
For i = fldInbox.Items.Count To 1 Step -1
Set objItem = fldInbox.Items(i)
' 処理対象となる分類項目が設定されていたら
If InStr(objItem.Categories, MOVE_MARK) > 0 Then
' 差出人のアドレスを取得
strAddr = objItem.SenderEmailAddress
' Dictionary にアドレスが設定されていたら
If dicRules.Exists(strAddr) Then
' Dictionary からフォルダー名を取得
strFolder = dicRules(strAddr)
' 受信トレイのサブフォルダーを取得
Set fldDest = fldInbox.Folders(strFolder)
' アイテムを指定されたフォルダーに移動
objItem.Move fldDest
End If
End If
Next
End Sub
'
' CSV ファイルの内容を Dictionary オブジェクトに読み込むマクロ
Private Sub ImportRulesFromCSV(dicRules As Object)
' 移動ルールが格納されている CSV ファイルのファイル名
Const CSV_FILE = "c:\temp\moverules.csv"
Dim strFolder As String
Dim strAddrs As String
Dim arrAddrs As Variant
Dim strAddr As Variant
' CSV ファイルを読み込みのため開く
Open CSV_FILE For Input As #1
' 1 行目はヘッダーのためスキップ
Line Input #1, strFolder
' ファイルの終わりまで繰り返す
While Not EOF(1)
' CSV からフォルダーとアドレスを読み込み
Input #1, strFolder, strAddrs
' アドレスに ; が含まれていなければ単一のアドレス
If InStr(strAddrs, ";") = 0 Then
' アドレスが Dictionary になければ
If Not dicRules.Exists(strAddrs) Then
' アドレスをキーとしてフォルダー名を Dictionary に追加
dicRules.Add strAddrs, strFolder
End If
Else
' ; を区切りとして文字列を分割
arrAddrs = Split(strAddrs, ";")
' 分割したアドレスごとに処理
For Each strAddr In arrAddrs
' アドレスが Dictionary になければ
If Not dicRules.Exists(strAddr) Then
' アドレスをキーとしてフォルダー名を Dictionary に追加
dicRules.Add strAddr, strFolder
End If
Next
End If
Wend
Close #1
End Sub
マクロの登録方法やメニューへの追加について
Outlook 研究所 