前の月に受信したメールのうち、特定のキーワードを含むメールをカウントするマクロ

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


マクロ作成について、ご教示ください。
outlook2013を使用しています。
ある特定の期間に受信したメールのうち、
件名に特定のキーワードが入っているメールをカウントし、
件数とその件名を抽出したいと思っています。
また、今日を基準に、先月を自動算出し、
先月分の条件に該当するメールをカウントするなどは可能でしょうか。
よろしくお願いします。



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

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub FindMailByKeywordLastMonth()
    On Error Resume Next
    ' 検索するキーワードを指定
    Const SEARCH_KEY = "test"
    ' レポートを作成するファイルのフルパスを指定
    Const REPORT_FILE = "c:\temp\report.txt"
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim colItems As Items
    Dim objItem As Object
    Dim cntItems As Integer
    Dim strReport As String
    ' 前月を表す日付範囲を算出
    dtEnd = Year(Now) & "/" & Month(Now) & "/1"
    dtStart = DateAdd("m", -1, dtEnd)
    ' 日付範囲でフィルタリング
    Set colItems = Session.GetDefaultFolder(olFolderInbox).Items
    colItems.Restrict "[受信日時] >= #" & dtStart & "# AND " & _
        "[受信日時] <  #" & dtEnd & "#"
    cntItems = 0
    strReport = ""
    ' フィルタリングしたメールを確認
    For Each objItem In colItems
        ' 件名にキーワードを含む場合はカウンタとレポート追加
        If InStr(objItem.Subject, SEARCH_KEY) > 0 Then
            cntItems = cntItems + 1
            strReport = strReport & objItem.ReceivedTime & vbTab & objItem.Subject & vbCrLf
        End If
    Next
    ' レポート作成
    Open REPORT_FILE For Output As #1
    Print #1, SEARCH_KEY & "を含むメールの件数:", cntItems
    Print #1, strReport
    Close #1
    ' レポートをメモ帳で表示
    Shell "notepad.exe " & REPORT_FILE
End Sub

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

場所から自動的に会議室メールボックスを宛先に追加するマクロ

Exchange サーバー環境では会議室のためのメールボックスを作り、会議出席依頼で会議室の予約を行うことができます。
また、会議室のメールボックスをリソースとして宛先に追加すると、同時に会議アイテムの [場所] にその会議室が設定されます。
この機能は非常に便利なのですが、ちょっと厄介なのが [場所] の履歴に会議室が残るという点です。
[場所] フィールドの右にはドロップダウンがあり、過去に使用した場所を選択することができるのですが、以前送信した会議室のメールボックスを指定しても宛先には自動では含まれません。
そのため、[場所] で会議室を選択した後、改めて会議室をリソースとして宛先に追加しなおす必要があるのです。
この操作を忘れて会議室を予約し忘れるということが発生しがちなので、場所に設定した会議室を宛先に追加し忘れていた場合に、自動で設定するマクロを作ってみました。
以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If TypeName(Item) = "MeetingItem" Then
        ReplaceLocationToResource Item
    End If
End Sub
'
Private Sub ReplaceLocationToResource(ByVal meetItem As MeetingItem)
    Const PR_DISPLAY_TYPE_EX = "http://schemas.microsoft.com/mapi/proptag/0x39050003"
    Const DT_ROOM = 7
    Dim apptItem As AppointmentItem
    Dim resRecip As Recipient
    Dim bDelete As Boolean
    '
    Set apptItem = meetItem.GetAssociatedAppointment(False)
    If InStr(apptItem.Resources, apptItem.Location) > 0 Then
        Exit Sub    ' すでにリソースに登録済みなら終了
    End If
    Set resRecip = meetItem.Recipients.Add("=" & apptItem.Location)
    bDelete = True
    resRecip.Resolve
    If resRecip.Resolved Then
        If resRecip.AddressEntry.Type = "EX" Then
            If resRecip.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
                Dim exchUser As ExchangeUser
                Set exchUser = resRecip.AddressEntry.GetExchangeUser
                If exchUser.PropertyAccessor.GetProperty(PR_DISPLAY_TYPE_EX) = DT_ROOM Then
                    bDelete = False
                End If
            End If
        End If
    End If
    '
    If bDelete Then
        resRecip.Delete
    Else
        resRecip.Type = olResource
        Set resRecip = apptItem.Recipients.Add("=" & apptItem.Location)
        resRecip.Resolve
        resRecip.Type = olResource
        apptItem.Save
    End If
End Sub

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

決まった件名で終わるメッセージを受信したら、キーワードを含む 1 行を CSV ファイルに保存するマクロ

決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロのコメントにて以下のご要望をいただきました。


横から失礼します。
本件に近い操作をしたいと考えています。
1.一定の文言が含まれるメールが対象
2.対象としたメール本文から、対象となる文言が含まれる部分(1行)を抜き出し、CSV化
具体的には
1.件名:「~を入力しました。」 ※「~」は、都度 異なります。
2.本文:「●:●● ■■会議 予約済」 →この「予約済」を対象として、その1行を抜き出してCSV化で一覧にしたいと思っています。
このような操作は可能でしょうか?また、どのように設定すれば良いでしょうか?
ご教示、お願い致します。
※初心者につき、説明がわかりにくいようでしたら すみません。

12で質問させていただいた内容に追記させてください。
受信時間と件名もCSVに記載したいです。
まとめると・・・
1.件名の「~を入力しました」をKeyにして
2.件名(フル)と受信時間+本文の一部(●:●● ■■会議 予約済 ←「予約済」をKeyに1行を抜き出す)をCSV化
したいです。
ご教示、よろしくお願いします。



変更点は以下の 2 になります。

  • 件名の先頭部分は可変
  • キーワードを含む 1 行を抽出

件名の一部が一致するという条件を指定する場合は LIKE という演算子を使用します。
例えば、「~を入力しました。」の「~」が可変なのであれば、以下のような条件定義になります。
    If myMsg.Subject Like "*を入力しました。"  Then

また、1 行を抜き出すというのは、言い換えると「キーワードの前後の改行を検索し、その間の文字列を取得する」ということになります。

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

' ここをトリプルクリックでマクロ全体を選択できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    SaveLineToCsv EntryIDCollection
End Sub
'
Private Sub SaveLineToCsv(ByVal EntryIDCollection As String)
    Const AUTO_SAVE_TITLE_SUFFIX = "を入力しました。" ' 自動処理するメールの件名の終わりの文字
    Const CSV_FILE = "c:\temp\data.csv" ' データを保存する CSV ファイルの名前
    Const SEARCH_KEY = "予約済み" ' 本文で検索するキーワード
    Dim i As Integer
    Dim arrEntryId
    Dim myMsg
    Dim stmCsv
    Set stmCsv = Nothing
    arrEntryId = Split(EntryIDCollection, ",")
    For i = LBound(arrEntryId) To UBound(arrEntryId)
        Set myMsg = Application.Session.GetItemFromID(arrEntryId(i))
        If myMsg.Subject Like "*" & AUTO_SAVE_TITLE_SUFFIX Then
            Dim s As Integer
            Dim e As Integer
            Dim strLine As String
            If stmCsv Is Nothing Then
                Dim objFSO
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                Set stmCsv = objFSO.OpenTextFile(CSV_FILE, 8, True, 0)
            End If
            ' キーワードを本文から検索
            e = InStr(myMsg.Body, SEARCY_KEY)
            If e > 0 Then ' キーワードを含む場合だけ処理
                ' キーワードを含む行の最初 (=直前の行の改行) を検索
                s = InStrRev(myMsg.Body, vbLf, e)
                If s = 0 Then
                    s = 1 ' 改行がなければ本文の先頭から
                End If
                e = InStr(e, myMsg.Body, vbCr)
                'キーワードを含む行の終わりを取得
                If e = 0 Then
                    e = Len(myMsg.Body)
                End If
                ' キーワードを含む行を取得
                strLine = Mid(myMsg.Body, s, e - s)
                strLine = Replace(strLine, vbCr, "")
                strLine = Replace(strLine, vbLf, "")
                stmCsv.WriteLine myMsg.Subject & "," & myMsg.ReceivedTime & "," & strLine
            End If
        End If
    Next
    If Not stmCsv Is Nothing Then
        stmCsv.Close
    End If
End Sub

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

本文から取得したデータを項目別に Excel のシートに書き出すマクロ

メールの内容を Excel ファイルにかき出すマクロ のコメントにて以下のご要望をいただきました。


はじめまして。
横からの質問で申し訳ありません。
どうしても自分では解決できずなんとかお力をお借りしたいと思います。

メールの本文中、

【 ご予定日 】 12月
【 日 】 31日
【 泊数 】 1泊
【 名前 】 山田 太郎
【 郵便番号 】 4562215
【 ご住所 】 愛知県豊明市西町5丁目111-111
【 マンション名等 】豊明マンション101
【 Email 】 taroyamada@yahoo.co.jp
【 tel1 】 0902200000
【 ご予約人数 】 2人
【 小学生以下人数 】 1人

のように項目ごとのフォーム送信がある場合、エクセルの2行目以降のセルに

(A1) (B1) …
ご予定日 日 泊数 名前 郵便番号 …
(A2) (B2) …
12 31 1 山田 太郎 4562215 …

のように①、メール本文内の項目の後の文字列を抽出し、エクセルの対象項目に対して個別にエクスポートすることは可能なのでしょうか?
またその折②、日にち、泊数などは数字のみ抽出できればうれしいです。
outlookのエクスポート機能はwordの差し込みフィールドのように使えて便利そうなのですが2003以降のバージョンには対応していないようですし、本文中の項目までは当然読み込めませんのでなんとかマクロで解決できればと思っております。
ただ、マクロはネットで引っ張りながらさわるぐらいしかできません。
こういった投稿、コメントに不慣れで甚だ不躾ではございますが是非ご教示頂ければ幸いです。
宜しくお願い申し上げます。

追記です。
出来れば既存のエクセルデータsheet内のセルに挿入できればと考えています。


本文から項目を取り出すというような便利な関数は Outlook には用意されていませんが、VBA の文字列検索関数を使って実現することはできます。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportBodyToExcel()
    ' エクスポートする Excel ファイルのファイル名を指定
    Const EXCEL_FILE = "c:\temp\book1.xlsx" 
    Dim objBook As Object
    Dim objSheet As Object
    Dim r As Integer
    Dim strBody As String
    ' Excel ファイルを開く
    Set objBook = GetObject(EXCEL_FILE)
    objBook.Windows(1).Activate
    Set objSheet = objBook.Worksheets(1)
    ' 空行を探す
    r = 1
    While objSheet.Cells(r, 1) <> ""
        r = r + 1
    Wend
    ' メールをどのように開いているか確認
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        strBody = ActiveInspector.CurrentItem.Body
    Else
        strBody = ActiveExplorer.Selection(1).Body
    End If
    ' セルに本文から取得したデータを格納
    objSheet.Cells(r, 1) = GetValueByToken(strBody, "ご予定日", True)
    objSheet.Cells(r, 2) = GetValueByToken(strBody, "日", True)
    objSheet.Cells(r, 3) = GetValueByToken(strBody, "泊数", True)
    objSheet.Cells(r, 4) = GetValueByToken(strBody, "名前", False)
    ' 郵便番号は文字列として保存
    objSheet.Cells(r, 5) = "'" & GetValueByToken(strBody, "郵便番号", False)
    objSheet.Cells(r, 6) = GetValueByToken(strBody, "ご住所", False)
    objSheet.Cells(r, 7) = GetValueByToken(strBody, "マンション名等", False)
    objSheet.Cells(r, 8) = GetValueByToken(strBody, "Email", False) 
    ' 電話番号は文字列として保存
    objSheet.Cells(r, 9) = "'" & GetValueByToken(strBody, "tel1", False)
    objSheet.Cells(r, 10) = GetValueByToken(strBody, "ご予約人数", True)
    objSheet.Cells(r, 11) = GetValueByToken(strBody, "小学生以下人数", True)
    ' 項目を追加したければ以下のフォーマットで追加 
    ' objSheet.Cells(r, 列番号) = GetValueByToken(strBody,"項目名", True) '数字のみ取り出す場合 
    ' objSheet.Cells(r, 列番号) = GetValueByToken(strBody,"項目名", False) '文字列として取り出す場合
    ' 変更したファイルを保存
    objBook.Save
    objBook.Close
    MsgBox "保存しました。"
End Sub
'
'  本文から指定された項目のデータを取得する関数
'
Private Function GetValueByToken(strBody As String, strToken As String, bNumOnly As Boolean)
    Dim i As Integer
    Dim strLine As String
    Dim strValue As String
    Dim c As String
    i = InStr(strBody, "【 " & strToken & " 】")
    If i > 0 Then
        strValue = ""
        strLine = Mid(strBody, i + Len(strToken) + 4)
        i = InStr(strLine & vbCrLf, vbCrLf)
        ' 余計な空白を削除
        strValue = Trim(Left(strLine, i - 1))
        If bNumOnly Then  ' 数字のみが指定された場合
            For i = 1 To Len(strValue)
                c = Mid(strValue, i, 1)
                If c < "0" Or "9" < c Then
                    strValue = Left(strValue, i - 1)
                    Exit For
                End If
            Next
        End If
        GetValueByToken = strValue
    Else
        GetValueByToken = ""
    End If
End Function

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

メール本文中のハイパーリンクを置き換えるマクロ

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


お世話になります。
仕事でOutlook2010をOffice365サーバー環境で使用しています。
Outlookメール本文中のハイパーリンクを変更したい件でご相談させてください。
今回、会社の組織変更で、Windowsファイルサーバーの格納先パスを変更する必要が出てきました。
従来、
\\Fsrv02\913-ABC\01グループ公開\50役立つ資料」のパスを
\\Fsrv02\602-XYZ\001グループ公開\50役立つ資料」に変更する必要がある状況です。
その際、メール本文中にあるハイパーリンクを置き換えしたいのです。
メールには、
テキスト形式
HTML形式
リッチテキスト形式が混在しています。
メールは複数あり、フォルダー内すべてのメール本文を対象に検索して置き換えたい状況です。
できれば、テキストファイルに、変更前パスと、変更後パスを指定して、汎用性がもたせたら尚うれしいです。
弊サイトの情報も見させていただいたのですが、私の探し方が未熟なため、サンプルプログラムとして使わせていただけそうなものが見つかりませんでした。
どうか、宜しくお願い申し上げます。



以下のようなマクロで実現できます。 REPLACE_FILE で指定したファイル名のテキストファイルに、変更前のパスと変更後のパスを 1 行ずつタブで区切って格納してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ReplaceLinksInFolder()
    Const REPLACE_FILE = "c:\temp\replacelinks.txt"
    Dim objFSO As Object
    Dim stmFile As Object
    Dim strReplace As String
    Dim arrLine As Variant
    Dim arrOld() As String
    Dim arrNew() As String
    Dim i As Integer
    ' パスの変換情報をファイルから読み込み
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set stmFile = objFSO.OpenTextFile(REPLACE_FILE)
    strReplace = stmFile.ReadAll()
    stmFile.Close
    arrLine = Split(strReplace, vbCrLf)
    ReDim arrOld(UBound(arrLine))
    ReDim arrNew(UBound(arrLine))
    For i = LBound(arrLine) To UBound(arrLine)
        Dim arrField As Variant
        If InStr(arrLine(i), vbTab) = 0 Then
            ReDim Preserve arrOld(i)
            ReDim Preserve arrNew(i)
            Exit For
        End If
        arrField = Split(arrLine(i), vbTab)
        arrOld(i) = arrField(0)
        arrNew(i) = arrField(1)
    Next
    ' アイテムごとにパスの変換を行う
    Dim objItem As MailItem
    For Each objItem In ActiveExplorer.CurrentFolder.Items
        If objItem.BodyFormat = olFormatPlain Then
            ' テキスト形式なら単純なテキスト置き換え
            Dim strNewBody As String
            strNewBody = objItem.Body
            For i = LBound(arrOld) To UBound(arrOld)
                strNewBody = Replace(strNewBody, arrOld(i), arrNew(i))
            Next
            If strNewBody <> objItem.Body Then
                objItem.Body = strNewBody
                objItem.Save
            End If
        Else
            ' HTML または RTF の場合は Word コンポーネントを使用して置き換え
            Dim objInsp As Inspector
            Dim objWord As Object ' Word.Document
            Dim objLink As Object ' Word.Hyperlink
            Dim bFound As Boolean
            Set objInsp = objItem.GetInspector()
            Set objWord = objInsp.WordEditor
            ' テキスト置き換えを可能にするため、[メッセージの編集] を実行
            objInsp.Display
            objInsp.CommandBars.ExecuteMso "EditMessage"
            bFound = False
            For Each objLink In objWord.Hyperlinks
                For i = LBound(arrOld) To UBound(arrOld)
                    ' リンクアドレスが置き換え前の文字列で始まる場合は置き換え
                    If objLink.Address Like arrOld(i) & "*" Then
                        bFound = True
                        objLink.Address = Replace(objLink.Address, arrOld(i), arrNew(i))
                        If objLink.TextToDisplay Like arrOld(i) & "*" Then
                            objLink.TextToDisplay = Replace(objLink.TextToDisplay, arrOld(i), arrNew(i))
                        End If
                    End If
                Next
            Next
            If bFound Then
                objItem.Save
            End If
            objInsp.Close olDiscard
        End If
    Next
End Sub

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

日付の文字列を設定するいくつかの方法

Outlook の予定表を CSV ファイルにエクスポートするマクロ Ver 2 のコメントにて以下のご要望をいただきました。


Outlookの予定データを日報管理として
Accessかexcelにインポートして活用したいと考えています。
各個人でExportする事を前提として

以下の文章(一部ここでは省略)を除いて
ThisOutlookSessionにコピペしマクロ登録致しました。

‘ 他人の予定を出力するマクロ
Public Sub ExportOthersCalendar()
中略
End Sub

デジタル署名の作成、OUTLOOKも再起動しマクロを実行
画面ではなんの変化もなく一瞬不安になりましたが、
エクスポート先のファイル名とされている C: ドライブ直下を確認すると
mycalendar.csv が作成されていた。
中身を確認すると当月の予定がExportされていました。

以下の点を変更したいのですが…。

Q1:日単位や週単位としたい場合はどのようにすればよいのでしょうか?
マクロの文章に以下の説明があるのですが…

dtExport = Now ‘ 来月の予定をエクスポートする場合は Now の代わりに DateAdd(“m”,1,Now) を使用します。
‘ 月単位ではなく任意の単位にする場合は以下の記述を変更します。
strStart = Year(Now) & “/” & Month(Now) & “/1 00:00”
strEnd = DateAdd(“m”, 1, CDate(strStart)) & ” 00:00″
DateAdd 関数を調べてみました。m=月、d=日、ww=週が引数 interval の設定値のようです。
本日の予定をエクスポートしたい場合
“m”を”d”と変更することでよいのでしょうか?

dtExport = Now

dtExport = DateAdd(“d”,-1,Now)

上記部分のみの変更では当月の予定がExportされます。
下記部分も追加変更しましたが、
本日(2016/11/17)ではなく201611/01のデータがExportされました。

strEnd = DateAdd(“m”, 1, CDate(strStart)) & ” 00:00″

strEnd = DateAdd(“d”, 1, CDate(strStart)) & ” 00:00″

私の力ではこれ以上は無理です。
本日、昨日、先週の条件でエクスポートするにはどのように変更すればよいのでしょうか?

質問2:日付のデータの形式について
Exportされた日付データは 2016/11/17 (木) という曜日まで表示されている形式です。
2016/11/17のような 曜日を含まない形式でのExportはできないでしょうか?

どうかご指南頂ければ幸いです。
よろしくお願い申し上げます。



まず、質問 1 について説明します。

もともとのコードは、1 か月分を出力することを想定しているため、dtExport で指定した日付から年月を取得し、その月の 1 日を strStart としています。
そのため、日ごとの指定をしたい場合は、FormatDateTime 関数で日付のみを取り出した文字列を strStart と strEnd に指定する必要があります。
「本日」の場合は以下のような記述になります。

dtExport = Now
strStart = FormatDateTime(dtExport, vbShortDate)
strEnd = FormatDateTime(DateAdd("d", 1, dtExport), vbShortDate)

次に、「昨日」の場合は以下のような記述になります。

dtExport = Now
strStart = FormatDateTime(DateAdd("d", -1, dtExport), vbShortDate)
strEnd = FormatDateTime(dtExport, vbShortDate)

「先週」はちょっと厄介ですね。今日の日付が月曜日でも金曜日でも、「先週」をさす場合は通常日曜日から土曜日になるでしょう。
日付から曜日を取り出すのは Weekday 関数ですが、その値 + 6 日を引くと、先週の日曜日の日付になり、それが範囲の開始になります。
また、終了日は開始日の 7 日後です。
したがって、「先週」の範囲指定は以下のようになります。

dtExport = DateAdd("d", –(Weekday(Now) + 6), Now))
strStart = FormatDateTime(dtExport, vbShortDate)
strEnd = FormatDateTime(DateAdd("d", 7, dtExport), vbShortDate)

次に質問 2 についてですが、曜日を省いた文字列はすでに登場した FormatDateTime 関数により取得可能であり、本来なら FormatDateTime( 日付, vbShortDate) で曜日なしの日付文字列が取得できるはずです。
もし、Windows の設定などで曜日がついてしまうようであれば、以下のように Format 関数で日付だけを取得するという方法もあります。

""",""" & Format(objAppt.Start, "yyyy/mm/dd") & _

選択したメッセージをファイル名に部署名をつけて MSG ファイルまたは RTF ファイルとして保存するマクロ

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


初めまして。仕事でOutlook2013を利用しています。(ExchangeServer2013環境だと思われます。)
日々、大量のメールが届くため、PC本体に受信メールを自動保存する方法がないかと思い、次のマクロを参考にさせてもらいました。
⇒2010年11月18日「選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロ
ファイル名として、送信者の部署名を入れたいのですが可能でしょうか。
これまでの問合せを見たところ、部署名はExchangeUserオブジェクトのDepartmentプロパティにあることはわかりましたが、どのように取得すればよいのか(取得可能なのかも含めて)わかりません。ご教授願います。



送信者の情報は MailItem の Sender プロパティで取得可能です。
そして、送信者の部署名については、Sender の GetExchangeUser メソッドで ExchangeUser オブジェクトを取得し、その Department プロパティにより参照可能です。
選択したメッセージを MSG ファイルまたは RTF ファイルとして保存するマクロをファイル名に部署名を入れるよう修正したものは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' MSG として保存するマクロ
Sub SaveSelectedItemsAsMSG()
    SaveSelectedItemsToDisk olMSGUnicode
End Sub
'
' RTF として保存するマクロ
Sub SaveSelectedItemsAsRTF()
    SaveSelectedItemsToDisk olRTF
End Sub
'
' 保存するマクロのメイン
Sub SaveSelectedItemsToDisk(saveAsType As OlSaveAsType)
    On Error Resume Next
    Const SAVE_PATH = "c:\temp\" ' 保存するフォルダのパス。最後に必ず \ をつける
    Dim objItem 'As MailItem
    Dim strDept As String
    Dim strFileName As String
    Dim i As Integer
    Dim arrErrChars
    Dim objFSO
    Dim strExt
    If saveAsType = olRTF Then
        strExt = ".rtf"
    Else
        strExt = ".msg"
    End If
    arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' 現在表示中のフォルダで選択されたアイテムについて
    For Each objItem In ActiveExplorer.Selection
        ' 差出人の部署名を取得
        strDept = ""
        If objItem.Sender.AddressEntryUserType = olExchangeUserAddressEntry Then
            strDept = objItem.Sender.GetExchangeUser().Department & "_"
        End If
        ' ファイル名を受信日時、部署名と件名から作成
        strFileName = Format(objItem.ReceivedTime, "yyyymmdd_hhnn_")
        If Err.Number <> 0 Then
            ' エラーが発生したら受信日時ではなく最終更新日時とする
            strFileName = Format(objItem.LastModificationTime, "yyyymmdd_hhnn_")
            Err.Clear
        End If
        strFileName = strFileName & strDept & objItem.SenderName & "_" & objItem.Subject
        ' ファイル名として不適切な文字を _ に置き換える
        For i = 0 To UBound(arrErrChars)
            strFileName = Replace(strFileName, arrErrChars(i), "_")
        Next
        ' ファイル名が 260 文字を超えないようにする
        strFileName = Left(SAVE_PATH & strFileName, 250)
        ' 同名のファイルがある場合の処理
        If objFSO.FileExists(strFileName & strExt) Then
            i = 2
            ' (2) から始める
            While objFSO.FileExists(strFileName & "(" & i & ")" & strExt)
                i = i + 1
            Wend
            strFileName = strFileName & "(" & i & ")"
        End If
        ' ファイルをフォルダに保存
        objItem.SaveAs strFileName & strExt, saveAsType
    Next
End Sub

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