決まった件名のメールを受信した際にタスクを作成するマクロ

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


outlookのタスクの自動作成に関する情報が少なく困っています。
ある定型件名のメールを受信した時に、タスクとするスクリプトはどのようにしたら良いでしょうか?
outlook2010利用です。


タスクを作成するには Application オブジェクトの CreateItem メソッドで olTaskItem を指定して呼び出します。
作成した TaskItem オブジェクトについては Subject で件名、Body で本文を設定できるほか、StartDate (開始日) や DueDate (期限) などによりタスク アイテムのプロパティも設定できます。
TaskItem オブジェクトで使用可能なプロパティやメソッドの詳細については以下の URL をご覧ください。
https://docs.microsoft.com/ja-jp/office/vba/api/outlook.taskitem
以下は受信したメールが “タスク” という件名だった場合に、そのメールの件名と本文を設定したタスク アイテムを自動的に作成するマクロです。

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Const TASK_SUBJECT = "タスク" ' 自動処理するメールの件名
     Dim myMsg
     ' メッセージの取得
     Set myMsg = Session.GetItemFromID(EntryIDCollection)
     ' 指定の件名のメールのみ処理を実行
     If myMsg.Subject = TASK_SUBJECT Then
         CreateTaskByMail myMsg
     End If
End Sub
'
Private Sub CreateTaskByMail(ByVal myMsg As MailItem)
     Dim myTask As TaskItem
     Dim dtToday As Date
     ' タスク アイテムを作成
     Set myTask = CreateItem(olTaskItem)
     '
     dtToday = FormatDateTime(Now, vbShortDate)
     '
     With myTask
         ' タスクの件名にメールの件名を設定
         .Subject = myMsg.Subject
         ' タスクの本文にメールの本文を設定
         .Body = myMsg.Body
         ' 開始日を今日に設定
         .StartDate = dtToday
         ' 期限を明日に設定
         .DueDate = DateAdd("d", 1, dtToday)
         ' 期限日の朝 9 時にアラームを設定
         .ReminderTime = DateAdd("h", 9, .DueDate)
         ' アラームをオンに設定
         .ReminderSet = True
         ' タスク アイテムを保存
         .Save
     End With
End Sub

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

広告

部署のメンバーの予定表を追加する方法

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


いつも参考にさせて頂いております。
ありがとうございます。

この度、私(エクセルVBAであれば一通りできるレベル)が所属している会社(Win10 64bit outlook2013 exchange 環境)の部の上司より言われ、今後は各社員の外出先や戻る時間を記載するためのホワイトボードをやめ、各社員の行動はoutlookの共有予定表で把握したいということになりました。

予定表の共有(名前の横のチェックボックスにチェックを入れればその人の予定が表示される状態)のやり方は分かるのですが、なにぶん人数が多い部署のため、outlookのセットアップをエクセルのVBA(各位にエクセルファイルを配布してそのファイル上に用意されたボタンを押すとoutlookのセットアップを自動でやってくれるイメージ)でやりたいと考えております。

私が所属している部は1課と2課に分かれているのでその2つのグループに分け、各50人くらいずつの登録をVBAで行いたいです。

何卒知恵を頂きたくお願い申し上げます。


VBA で登録したいとのことですが、アクセス権限によっては VBA では実現できない可能性があります。
部署の全員の予定表を一括で登録する方法はいくつかあり、それぞれメリット、デメリットがありますので、どれが良いかご検討ください。

1. 階層型アドレス帳を構成し、[部署の予定表を表示] をオンにする

Exchange 環境では階層型アドレス帳という、部署をツリー形式で表示するアドレス帳が使用できます。
このアドレス帳が構成されている環境では、予定表のリボンの [予定表グループ]-[部署の予定表を表示] が既定でオンになり、階層型アドレス帳で自分自身が所属しているグループに含まれるメンバーの予定表が自動的にナビゲーション ウィンドウに表示される動作となります。

メリット:
階層型アドレス帳を構成するだけで自動的に追加される。

デメリット:
Exchange サーバーの管理者が階層型アドレス帳を構成し、適切にグループを作成する必要がある。

2. ユーザーに上司を設定し、[上司のチームの予定表を表示] をオンにする

Active Directory のユーザーの属性に [上司] というものがあり、ここに上司となるユーザーが登録されている場合、予定表のリボンの [予定表グループ]-[上司のチームの予定表を表示] が既定でオンになり、同じ上司であるユーザーの予定表が自動的にナビゲーション ウィンドウに表示される動作となります。

メリット:
Active Directory で上司を追加するだけで自動的に追加される。

デメリット:
Active Directory のユーザーの属性を変更する必要がある。
一人の上司が複数の部署の上司を兼任している場合、別の部署のメンバーも追加される。

3. 部署のメンバーで構成される配布グループを作成し、[予定表を開く]-[アドレス帳から] で配布グループを追加する

[予定表を開く]-[アドレス帳から] により、アドレス帳から配布グループを追加すると、そのグループの名前の予定表グループが生成され、その下に配布グループのメンバーの予定表が追加されます。

メリット:
組織によってはグループの生成がある程度自由なため、敷居が低い。

デメリット:
グループを作成する必要がある。
ユーザーが手動で配布グループを追加する必要がある。

4. VBA マクロで追加する

メンバーの予定表に参照権限以上がある場合は、マクロで追加することが可能です。
ただし、上記の 3 つにはない制限があります。

メリット:
Active Directory の設定変更の必要がない。

デメリット:
予定表に参照権限を与える必要がある (上記 1-3 は空き時間情報のみで追加可能)。
部署のメンバーの追加・削除があった場合は、改めてクライアントごとにマクロの実行が必要 (上記 1-3 は Active Directory 上のメンバーや上司の変更がクライアントに自動的に反映される)。
追加された予定表の名前がユーザー名だけでなく、「予定表 – ユーザー名」となる。(変更は不可能)

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

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

Public Sub AddMemberCalendars()
     On Error Resume Next
     Const GROUP_NAME = "group"
     Const olFolderCalendar = 9
     Const olModuleCalendar = 1
     Dim olkApp 'As Outlook.Application
     Dim nsSession 'As Namespace
     Dim actExp 'As Explorer
     Dim navModule 'As CalendarModule
     Dim navGroups 'As NavigationGroups
     Dim navGroupT 'As NavigationGroup
     Dim navGroup 'As NavigationGroup
     Dim i As Integer
     Dim j As Integer
     Dim r As Integer
     Dim recOther 'As Recipient
     Dim fldCalendar 'As Folder
     '
     Set olkApp = CreateObject("Outlook.Application")
     Set nsSession = olkApp.Session
     '---- 予定表グループの作成
     ' 予定表グループを追加するための Explorer オブジェクトを取得
     If olkApp.ActiveExplorer Is Nothing Then
         Set fldCalendar = nsSession.GetDefaultFolder(olFolderCalendar)
         Set actExp = fldCalendar.GetExplorer()
     Else
         Set actExp = olkApp.ActiveExplorer
     End If
     ' 予定表モジュールを取得
     Set navModule = actExp.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
     ' 予定表グループのリストを取得
     Set navGroups = navModule.NavigationGroups
     Set navGroup = Nothing
     For i = 1 To navGroups.Count
         Set navGroupT = navGroups.Item(i)
         ' 追加しようとしているグループが既に存在していた場合
         If navGroupT.Name = GROUP_NAME Then
             ' 既存の予定表はすべて削除
             With navGroupT.NavigationFolders
                 For j = .Count To 1 Step -1
                     Dim navFolder 'As NavigationFolder
                     Set navFolder = .Item(j)
                     .Remove navFolder
                 Next
             End With
             ' 既存の予定表グループを設定
             Set navGroup = navGroupT
             Exit For
         End If
     Next
     '
     If navGroup Is Nothing Then
         ' 新規に予定表グループを作成
         Set navGroup = navGroups.Create(GROUP_NAME)
     End If
     '---- 予定表グループにメンバーの予定表を追加
     ' 1 行目から開始
     r = 1
     ' 1 列目にデータがある限り繰り返す
     While ThisWorkbook.Sheets(1).Cells(r, 1) <> ""
         ' 1 列目をメールアドレスとして取得
         strAddress = ThisWorkbook.Sheets(1).Cells(r, 1)
         ' メールアドレスから受信者オブジェクトを生成
         Set recOther = nsSession.CreateRecipient(strAddress)
         ' 名前解決を実行
         recOther.Resolve
         If recOther.Resolved Then
             ' 自分自身は予定表グループに追加しない
             ' Exchange 組織外のアドレスも追加しない
             If recOther.Address = nsSession.CurrentUser.Address _
                 Or recOther.AddressEntry.Type <> "EX" Then
                 Exit Sub
             End If
             ' 他のユーザーの予定表を取得
             Set fldCalendar = nsSession.GetSharedDefaultFolder(recOther, olFolderCalendar)
             If Not fldCalendar Is Nothing Then
                 ' 予定表が取得できたら予定表グループに追加
                 navGroup.NavigationFolders.Add fldCalendar
             End If
         End If
         r = r + 1
     Wend
End Sub

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

特定のフォルダーにあるメールに更新した Excel ファイルを添付して返信するマクロ

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


とても素晴らしいサイトにたどりつきコメントさせていただきます。
お力をお貸しいただきたいです。

▼使用環境
OS:Windows 10 Pro Ver.1803 ビルド.17134.471
  Outlook2016 16.0.9126.2259

▼参考にした過去記事
Excel のリストにしたがってファイルを添付して送信するマクロ

▼やりたいこと
1)グループメールに届くメールを個人メールフォルダ(A)にコピーし、添付ファイルを取り出す。おおよそ30通ほどあります。
   届くメールはタイトルにそれぞれ数字の羅列があります。
   添付ファイルは「0005-0200」形式の名前+.csv/.xls/.pdf の3ファイルである。(B)
  名前は数字部分が都度変わります。規則性はなし。タイトルとの関連性もなし。

  こちらはエクセルVBA(C)にてファイルの取り出し済み。以下の形式でエクセル(C)にリスト出力されています。
   A列:番号(連番のメール番号)
   B列:受信日時
   C列:タイトル
   D列:送信元アドレス
   E列:添付ファイル数
   F列:エクセルファイル名

2).csv/.pdfファイルは不要なので削除し、エクセルファイル(B)に加工を加え(加工後のもの=B’)、上書き保存する。

3)個人メールフォルダ(A)のメールに1通ずつ返信する。(一括でやりたい)
  本文に定型文書を添付。
   CCにメールアドレスを追加したい。
   元メールに添付されていたものと同じファイル(B)の加工済みファイル(B’)を添付して送信したい。

▼状況
1)、2)までは運用できている状態です。
3)からができずに困っています。

▼困っていること
  メール1通に対して返信というのは他のVBAを参照してできるかと思いますが、該当ファイルを添付する、更にはこのフォルダ(A)に入っているメールすべてに適用する場合はどのようにしたらよいかわかりません。
  希望としては先にリスト化しているエクセル(C)のタイトルと添付ファイル名の情報をもとに対応する添付ファイルを添付する方法が望ましいと思いますがそもそもOUTLOOK VBAの範疇なのでしょうか。もしくはOUTLOOK VBAで1通ずつならばエクセル(C)の情報は使わずに自動で本文に定型文を追加し、該当ファイル(B’)を添付し送信できるものなのでしょうか。

お力おかしいただきたく、お願い申し上げます。


特定のフォルダーに格納されているすべてのアイテムに対して処理を行うには、For Each を使って指定したフォルダーの Items に含まれるアイテムを処理するループを記述します。

そして、返信メールに加工済みのファイルを添付するということですが、加工済みファイルは上書き保存しているということなので、ファイル名は元のメールの添付ファイルのファイル名と同じと考えられます。
したがって、Excel ファイルを使わなくても、以下のような流れで返信メールを作成することは可能でしょう。

  1. フォルダーのメールの添付ファイルのファイル名をチェック
  2. ファイルが Excel ファイルであれば、そのファイル名を保存して返信メールを作成
  3. 加工済みの Excel ファイルが格納されているフォルダーから同じファイル名のファイルを返信メールに追加

以下の前提条件で動作するマクロを作成しました。

  • 処理をするメールは受信トレイの下に作成したサブ フォルダーに格納されている
  • 返信メールの本文を記載したメールがマクロの OFT_FILE で定義したファイル名であらかじめ作成されている
  • 添付ファイル名が複数のメールで重複することはない

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

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

Public Sub ReplyWithAttachmentInFolder()
     ' メールが格納されているフォルダー (受信トレイのサブ フォルダー)
     Const FOLDER_NAME = "Test"
     ' 返信メールの本文を設定した OFT ファイル
     Const OFT_FILE = "c:\temp\reply.oft"
     ' CC に追加するアドレス
     Const CC_ADDRESS = "cc@example.com"
     ' 変更後の添付ファイルが格納されているフォルダー
     Const ATTACH_FOLDER = "c:\temp\" ' 最後に \ をつける
     '
     Dim fldInbox As Folder
     Dim fldCurrent As Folder
     Dim itmTemp As MailItem
     Dim itmOrig As MailItem
     Dim attFile As Attachment
     Dim strFileName As String
     Dim itmReply As MailItem
     Dim ccRecip As Recipient
     ' メールが格納されているフォルダーを取得
     Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
     Set fldCurrent = fldInbox.Folders(FOLDER_NAME)
     ' テンプレートからメールを作成
     Set itmTemp = CreateItemFromTemplate(OFT_FILE)
     ' フォルダー内のすべてのメールを処理
     For Each itmOrig In fldCurrent.Items
         strFileName = ""
         ' アイテムの添付ファイルをチェック
         For Each attFile In itmOrig.Attachments
             If attFile.FileName Like "*.xls*" Then
                 ' Excel ファイルだったらファイル名を取得
                 strFileName = attFile.FileName
             End If
         Next
         ' Excel ファイルが見つかったら返信処理
         If strFileName <> "" Then
             ' 全員に返信
             Set itmReply = itmOrig.ReplyAll
             ' CC にアドレスを追加
             Set ccRecip = itmReply.Recipients.Add(CC_ADDRESS)
             ccRecip.Type = olCC
             ' テンプレートの本文を返信メールに設定
             If itmReply.BodyFormat = olFormatHTML Then
                 itmReply.HTMLBody = itmTemp.HTMLBody
             Else
                 itmReply.Body = itmTemp.Body
             End If
             ' 更新された Excel ファイルを添付
             itmReply.Attachments.Add ATTACH_FOLDER & strFileName
             ' メールを送信
             itmReply.Send
         End If
     Next
     '
     itmTemp.Delete
End Sub

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

Excel マクロからメールを送信する際に送信アカウントを指定する方法

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


初歩的な質問で申し訳ありません。
  小生の環境は、Windows10/Office365です。
Excel VBAは趣味として長くやっており、また、Excel VBAからOutlookでの送信も行ったことが多数あります。

質問内容は以下の通りです。
Outlookで2つのアドレス”A@Outlook.jp”と”B@Outlook.jp”を持っており、”A@Outlook.jp”が元々あったアドレスです。
”A”は個人用に使っており、ボランティアとして参加している団体との送受信用に”B”を使いたいと考えています。
Excel VBAから差出人を”B@Outlook.jp”としてメールを送信したいのですが、”.Save”で下書きを作り、プルダウンで差出人を切り替えて送信することはできるのですが、どうせなら直接”B”から”.Send”で送信したいと思っております。.Senderとか.SendUsingAccount、.SentOnBehalfOfNameを試しているのですが、いまいち上手くいきません。どうしたらよいのか、お教えください。
また、その際、表示される名前も”????”ではなく、指定する表示名で相手先に送信したいと思っています。何かいい方法はないでしょうか?


送信の際のアカウントを指定するには、「特定の受信者に送信する際に自動的に送信アカウントを変更するマクロ」で紹介した SendUsingAccount を使うのですが、上記のマクロと同じやり方を Excel などでやろうとするとエラーが発生してしまいます。
というのも、このマクロは Outlook 上で使用することを前提としており、省略されている記述があるためです。
このマクロのアカウントの取得は Session.Accounts(アカウント名) という記述を使っていますが、これを Outlook 以外の環境で使用する場合は、Session.Accounts.Item(アカウント) というように記述する必要があるのです。
以下は Excel など Outlook 以外のアプリケーションのマクロからアカウントを指定してメールを送信するマクロのサンプルです。

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

Public Sub SendUsingAccountFromExcel()
    Const SEND_ACCOUNT = "sender@example.com"
    Const SEND_TO_ADDRESS = "to@example.com"
    Const MAIL_SUBJECT = "テスト メッセージ"
    Const MAIL_BODY = "Excel から送信しました。"
    Dim olkApp
    Dim objItem
    Dim acctToSend
    ' Outlook のオブジェクトを取得
    Set olkApp = CreateObject("Outlook.Application")
    ' メールアイテムを作成
    Set objItem = olkApp.CreateItem(0)
    ' 宛先、件名、本文を指定
    objItem.To = SEND_TO_ADDRESS
    objItem.Subject = MAIL_SUBJECT
    objItem.Body = MAIL_BODY
    ' 送信アカウントを取得
    Set acctToSend = olkApp.Session.Accounts.Item(SEND_ACCOUNT)
    ' 送信アカウントを指定
    Set objItem.SendUsingAccount = acctToSend
    ' メールを送信
    objItem.send
End Sub

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

決まった件名のメッセージを受け取ったら添付された CSV ファイルの 2 行目を Excel ファイルの最後尾に追加するマクロ

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


特定の件名で始まるメールを受信したら、
  添付されたcsvファイルの2行目(1行目は項目名なので除外)を、
マスター(excel)ファイル最後尾に追加していく
  という処理を自動化したいのですが、
outlookマクロで可能でしょうか。

メールの内容を Excel ファイルにかき出すマクロ
決まった件名で終わるメッセージを受信したら、キーワードを含む 1 行を CSV ファイルに保存するマクロ
受信したメールに添付された Excel ファイルをもとに別の Excel ファイルの内容を更新するマクロ
  このあたりを参考にしたのですが、
・最後尾に追加していく
  ・csvから読み込む
  あたりで詰まってしまいました。


まず、最後尾に追加するという処理ですが、通常は 1 列目にデータが格納されていない行を探すという方法で最後尾を見つけることができると考えられます。
次に、CSV ファイルを読み込むという処理ですが、これには以下のような方法が考えられます。

  1. CSV ファイルをテキスト ファイルとして開き、テキスト データを Split 関数などにより加工してデータを取りだす
  2. CSV ファイルを Excel の Workbooks オブジェクトの Open メソッドにより開く

今回は 2 の方法を使って実装してみました。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
      MergeCsvToExcel EntryIDCollection
End Sub
'
Private Sub MergeCsvToExcel(ByVal EntryIDCollection As String)
     Const AUTO_SAVE_TITLE = "タイトル" ' 自動処理するメールの件名
     Const CSV_BASE = "c:\temp\update" ' 一時保存する添付ファイル名の接頭語
     Const EXCEL_FILE = "c:\temp\master.xlsx" ' 保存する Excel ファイルの名前
     Dim i As Integer
     Dim myMsg As MailItem
     ' メッセージの取得
     Set myMsg = Session.GetItemFromID(EntryIDCollection)
     ' 指定の件名のメールのみ処理を実行
     If myMsg.Subject = AUTO_SAVE_TITLE Then
         Dim strCsvFile As String
         Dim bookCsv
         Dim bookMaster
         Dim objSheet
         Dim r As Integer
         Dim rowDest
         ' 添付ファイルがなければ処理を中断
         If myMsg.Attachments.Count = 0 Then
             Exit Sub
         End If
         ' 添付ファイルを保存するための一時ファイル名を作成
         strCsvFile = CSV_BASE & Timer() & ".csv"
         ' 添付ファイルを保存
         myMsg.Attachments.Item(1).SaveAsFile strCsvFile
         ' Excel ファイルを開く
         Set bookMaster = GetObject(EXCEL_FILE)
         bookMaster.windows(1).Activate
         Set objSheet = bookMaster.Sheets(1)
         ' 1 行目はタイトルとして使用し、2 行目からデータ
         r = 2
         ' データがない行 (= 末尾) まで移動
         While objSheet.Cells(r, 1) <> ""
             r = r + 1
         Wend
         ' ファイル末尾をコピー先として取得
         Set rowDest = objSheet.Rows(r)
         ' CSV ファイルを Excel で開く
         Set bookCsv = bookMaster.Application.Workbooks.Open(strCsvFile)
         ' CSV ファイルの 2 行目を Excel ファイルに転記
         bookCsv.Sheets(1).Rows(2).Copy rowDest
         ' Csv ファイルを閉じる
         bookCsv.Close False
         ' Excel ファイルを閉じる
         bookMaster.Close True
         ' 一時保存した CSV ファイルを削除
         Kill strCsvFile
     End If
End Sub

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

最後にバックアップした日時以降に受信したメールを PST にバックアップするスクリプト

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


教えてください。Outlook 2016 のメールのエクスポートコマンドを、VBScriptから呼び出して
定期的に受信トレイのメールをPSTファイルをバックアップする方法を知りたいです。

フィルターとして受信日時を直前のバックアップ日時以降として、PSTファイル名は現日時と
することで、重複なしでバックできると、嬉しいです。


残念ながら Outlook のエクスポート機能を Outlook オブジェクト モデルで呼び出すことはできません。

ただ、PST へのバックアップを行うという処理をスクリプトで実装することは可能です。
NameSpace オブジェクトの AddStoreEx メソッドを使うと PST をプロファイルに追加することができます。
そして、追加した PST に「受信トレイ」というフォルダーを作成し、既定の受信トレイのアイテムをコピーすることでバックアップが実現できます。
最後に、追加した PST は RemoveStore でプロファイルから削除できます。
なお、特定の日時以降に受信したメールのみをバックアップするには、Items オブジェクトの Restrict メソッドを使ってフィルタリングを行います。
また、最後にバックアップした日時を保存する方法については、今回のスクリプトでは StorageItem オブジェクトを使用しています。
まとめると、以下のようなスクリプトになります。

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

' バックアップ PST を保存するフォルダーの指定
Const PST_ROOT = "c:\backup\"
Const MSGCLASS_ETP = "IPM.OutlookLab.ExportToPst"
' Outlook の定数指定
Const olStoreDefault = 1
Const olFolderInbox = 6
Const olIdentifyByMessageClass = 2
Dim olkApp 'As Outlook.Application
Dim objSession 'As Namespace
Dim strStartTime 'As String
Dim oneStore 'As Store
Dim strPstName 'As String
Dim fldPst 'As Folder
Dim fldPstInbox 'As Folder
Dim fldInbox 'As Folder
Dim stgItem 'As StorageItem
Dim strLastBackup 'As String
Dim colItems 'As Items
Dim srcItem 'As MailItem
Dim dstItem 'As MailItem
' Outlook オブジェクトの生成
Set olkApp = CreateObject("Outlook.Application")
Set objSession = olkApp.Session
' 現在の日付と時刻を取得
strStartTime = Now
' 現在の日付と時刻により PST ファイルの名前を作成
strPstName = Replace(Replace(Replace(strStartTime, "/", ""), ":", ""), " ", "")
' PST ファイルをプロファイルに追加
objSession.AddStoreEx PST_ROOT & strPstName & ".pst", olStoreDefault
' 追加した PST のルート フォルダーを検索
For Each oneStore In objSession.Stores
     If oneStore.FilePath = PST_ROOT & strPstName & ".pst" Then
         Set fldPst = oneStore.GetRootFolder
         fldPst.Name = "Backup " & strStartTime
         Exit For
     End If
Next
' PST に受信トレイ フォルダーを作成
Set fldPstInbox = fldPst.Folders.Add("受信トレイ")
' 既定の受信トレイを取得
Set fldInbox = objSession.GetDefaultFolder(olFolderInbox)
' バックアップ日時を保存する StorageItem を作成
Set stgItem = fldInbox.GetStorage(MSGCLASS_ETP, olIdentifyByMessageClass)
' StorageItem の件名が最終バックアップ日時
strLastBackup = stgItem.Subject
stgItem.Subject = FormatDateTime(Now, vbShortDate) & " " & FormatDateTime(Now, vbShortTime)
stgItem.Save
' 最終バックアップ日時を確認
If strLastBackup = "" Then
     ' 日時が設定されていなければすべてのアイテムをバックアップ
     Set colItems = fldInbox.Items
Else
     ' 最終バックアップ日時より後に受信したアイテムをフィルタリング
     Set colItems = fldInbox.Items.Restrict("[受信日時] > '" & strLastBackup & "'")
End If
' フィルタリングされたアイテムを PST にコピー
For Each srcItem In colItems
     Set dstItem = srcItem.Copy
     dstItem.Move fldPstInbox
Next
' PST ファイルをプロファイルから切断
objSession.RemoveStore fldPst

決まった件名のメッセージを受信したら、データを Excel ファイルに保存するマクロ

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


こんにちわ。
  指定のタイトルのメールを受信した場合に、本文の一部をエクセルにコピーするマクロはどのように作成するか、教えていただけないでしょうか。
  例えば
  タイトル
  ・タイトル
本文
・番号:〇〇○
・氏名:△△△
・住所:◻︎◽︎◻︎
・生年月日:××
・依頼内容:☆☆☆
というメールを受け取った際に、番号欄の〇〇○、氏名欄の△△△、依頼内容の☆☆☆のみを指定のエクセルデータに一覧として出力をしたいです。
エクセルの1行目には番号、氏名、依頼内容など項目名は事前にある状態です。
  複数のメールの内容を一つのエクセルに一覧として入力をしたいです。
  以上、よろしくお願いします。


以前、決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロとして似たようなマクロを公開していますが、こちらのマクロでテキストファイルに書き出している処理を Excel ファイルへの書き出しに変更することでご要望は実現できます。
マクロは以下のようになります。


' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     SaveToExcel EntryIDCollection
End Sub
'
Private Sub SaveToExcel(ByVal EntryIDCollection As String)
     Const AUTO_SAVE_TITLE = "タイトル" ' 自動処理するメールの件名
     Const EXCEL_FILE = "c:\temp\request.xlsx" ' 保存する Excel ファイルの名前
     Dim i As Integer
     Dim myMsg
     ' メッセージの取得
     Set myMsg = Session.GetItemFromID(EntryIDCollection)
     ' 指定の件名のメールのみ処理を実行
     If myMsg.Subject = AUTO_SAVE_TITLE Then
         Dim objBook
         Dim objSheet
         Dim r As Integer
         Dim strCode
         Dim strName
         Dim strQuantity
         ' Excel ファイルを開く
         Set objBook = GetObject(EXCEL_FILE)
         objBook.windows(1).Activate
         Set objSheet = objBook.sheets(1)
         ' 1 行目はタイトルとして使用し、2 行目からデータ
         r = 2
         ' データがない行まで移動
         While objSheet.Cells(r, 1) <> ""
             r = r + 1
         Wend
         ' 本文から取り出したデータを Excel ファイルに転記
         With objSheet
             .Cells(r, 1) = GetText("番号:", myMsg.Body)
             .Cells(r, 2) = GetText("氏名:", myMsg.Body)
             .Cells(r, 3) = GetText("依頼内容:", myMsg.Body)
         End With
         ' Excel ファイルを閉じる
         objBook.Close True
     End If
End Sub
' 本文からデータを取得する関数
Private Function GetText(strName As String, strBody As String) As String
     Dim ls As Long
     Dim le As Long
     ls = InStr(strBody, strName) ' 指定されたフィールド名を検索
     If ls > 0 Then
         ls = ls + Len(strName) ' フィールド名の次の文字から
         le = InStr(ls, strBody, vbCrLf) ' 改行コードまでを取得
         GetText = Trim(Mid(strBody, ls, le - ls)) ' 前後の空白を削除
     Else
         GetText = ""
     End If
End Function

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