Outlookでムダなメールをカット！検索フォルダを自動生成する裏技公開

どーもボキです。

Outlookの検索フォルダを使えば、パっと見で急いで処理すべきメールがわかるようになるんです

Outlookの検索フォルダ機能を使えば、以下ができます。

• 受信メールのうち、納期付きのみを抽出する
• 受信メールのうち、宛先で受け取ったメールのみを抽出する
• 送信メールのうち、納期付きのみを抽出する

など、です。

上記も、検索フォルダを使いこなせば、できなくはないものの、設定自体が若干メンドウです。

ならば、レッツ、スクリプティング！！ツール化しときました。

下図のように５つの検索フォルダをカンタンに作れますよ。

• フラグ付き：受信
• フラグ付き：送信
• 受信：宛先＋分類
• 受信：ＣＣ
• 送信
  

サンプルプログラムのダウンロードと使い方

• ダウンロードはこちらから。
• 使い方は、実行する、だけ。
  

今回開発したプログラムソース

SetScriptHost "cscript"

cDisplayDays = 30 ' 表示日数

' Outlookを起動（or 起動済みのOutlookの取得）

Dim Outlook

Set Outlook = CreateObject("Outlook.Application")

Dim OutlookNS

Set OutlookNS = Outlook.GetNamespace("MAPI")

Const PidTagFlagStatus = "http://schemas.microsoft.com/mapi/proptag/0x10900003"

Const PidTagSenderName = "http://schemas.microsoft.com/mapi/proptag/0x0c1a001f"

Const PidTagDisplayCc = "http://schemas.microsoft.com/mapi/proptag/0x0e03001f"

Dim s_filter, arr()

s_flagOn = PidTagFlagStatus & " > 2" ' フラグ付き

s_fromMe = PidTagSenderName & " = '" & OutlookNS.CurrentUser & "'" ' 差出人が自分である

s_CCtoMe = PidTagDisplayCc & " Like '%" & OutlookNS.CurrentUser & "%'" ' CCに自分がある

s_disp = "urn:schemas:httpmail:datereceived > '" & cDisplayDays & " days ago'" ' 表示日数以降である

s_cate = "urn:schemas-microsoft-com:office:office#Keywords is null" ' カテゴリが空である

s_folder = "http://schemas.microsoft.com/mapi/proptag/0x0e05001f Like '__%'" ' フォルダ名が「__」で始まる

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

s_name = "フラグ付き：受信"

Redim arr(1)

arr(0) = "(" & s_flagOn & ")"

arr(1) = "(Not(" & s_fromMe & "))" ' 差出人が自分でない

s_filter = Join(arr, " and ")

Call CreateAdvancedSearch("'Inbox'", s_filter, True, s_name)

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

s_name = "フラグ付き：送信"

Call CreateAdvancedSearch("'Sent Items'", s_flagOn, True, s_name)

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

s_name = "受信：宛先＋分類"

Redim arr(1)

arr(0) = "Not(" & s_CCtoMe & ")" ' CCに自分がない

arr(1) = "Not(" & s_cate & ")" ' カテゴリが空ではない

s = Join(arr, " or ") ' CCに自分がなく、カテゴリが空でない

arr(0) = "(Not(" & s_folder & "))" ' フォルダ名が「__」で始まらない

t = Join(arr, " or ") ' フォルダ名が「__」で始まらず、カテゴリが空でない

Redim arr(3)

arr(0) = "(" & s & ")"

arr(1) = "(" & t & ")"

arr(2) = "(" & s_disp & ")"

arr(3) = "(Not(" & s_fromMe & "))" ' 差出人が自分でない

s_filter = "(" & Join(arr, " and ") & ")"

Call CreateAdvancedSearch("'Inbox'", s_filter, True, s_name)

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

s_name = "受信：ＣＣ"

Redim arr(1)

arr(0) = "(" & s_CCtoMe & ")"

arr(1) = "(" & s_disp & ")"

s_filter = "(" & Join(arr, " and ") & ")"

Call CreateAdvancedSearch("'Inbox'", s_filter, True, s_name)

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

s_name = "送信"

Call CreateAdvancedSearch("'Sent Items'", s_disp, True, s_name)

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

WScript.StdOut.WriteLine Now & vbTab &" [END]"

WScript.StdIn.ReadLine

' ===============================================================================

' -------------------------------------------------------------------------------

' 検索フォルダを作る

' -------------------------------------------------------------------------------

Sub CreateAdvancedSearch(sTargetFolder, sFilter, bSearchSubFolders, sCreateFolderName)

On Error Resume Next

OutlookNS.DefaultStore.GetSearchFolders().Item(sCreateFolderName).Delete

Err.Clear

WScript.StdOut.WriteLine sCreateFolderName

WScript.StdOut.WriteLine vbTab & "ターゲット" & vbTab & "：" & sTargetFolder

WScript.StdOut.WriteLine vbTab & "フィルター" & vbTab & "：" & sFilter

WScript.StdOut.WriteLine vbTab & "階層処理" & vbTab & "：" & bSearchSubFolders

Dim objSearch

Set objSearch = Outlook.AdvancedSearch(sTargetFolder, sFilter, bSearchSubFolders, "SearchFolder")

objSearch.Save sCreateFolderName

If Err Then

WScript.StdOut.WriteLine sCreateFolderName & vbTab & "：" & Err.Description

Else

WScript.StdOut.WriteLine sCreateFolderName & vbTab & "：作成しました"

End If

On Error Goto 0

WScript.StdOut.WriteLine "------------------------------------------------"

End Sub

' ----------------------------------------------------------------------------

' 実行ホストを切り替える

' ----------------------------------------------------------------------------

Sub SetScriptHost(HostName)

If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

Dim i,s

s = HostName & " //nologo """ & WScript.ScriptFullName & """"

If WScript.Arguments.Count > 0 Then

For i = 0 To WScript.Arguments.Count -1

s = s &" """ & WScript.Arguments.Item(i) & """" ' 引数

Next

End If

CreateObject("WScript.Shell").Run s

WScript.Quit

End Sub

参考URL

• Create an Outlook 2010 Search Folder using VBA (markwithall.com)
• Application.AdvancedSearch メソッド (Outlook) | Microsoft Learn
• 名前空間でプロパティを参照する | Microsoft Learn
• Outlook VBAでMAPIプロパティを取得する際のスキーマの一覧 - Qiita
• OUTLOOK VBA Categories 分類項目 まとめ - Qiita
• VBA - Outlook - Work With Search Folders | DEVelopers HUT (devhut.net)
• Professional Outlook 2007 Programming - Ken Slovak - Google ブックス
• カテゴリを持つアイテムをフィルター処理する | Microsoft Learn
• 文字列を比較してアイテムをフィルターにかける | Microsoft Learn
• 検索やフィルターの構文 - アルパカのメモ (vicugna-pacos.github.io)

にほんブログ村

2023年 01月 04日 の投稿記事を更新。以下ソースで検索フォルダを削除できるとわかったため、それを反映した。

OutlookNS.DefaultStore.GetSearchFolders().Item(sCreateFolderName).Delete

Err.Clear