共有メールボックスの受信トレイのメールを Excel ファイルにエクスポートするマクロ

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

---

共有メールフォルダに受信したメールをエクセルに書き出したい

outlookで個人アドレスの他に2つの共有アドレスを
使用しておりそれぞれのShared Mailboxに受信したメールをいちいち検索しなければいけない業務があります。
  個人の受信フォルダーにあるメールのエクセルへの
書き出しマクロは見かけるのですが共有ﾌｫﾙﾀﾞのものは見つけられません、
またそれらを参考に自作を試みたもののシステムエラー続きでお手上げです。
  受信時間、送信者、件名、本文（全文は不要）をエクセルに書き出すマクロを教えてください。

---

共有メールボックスの受信トレイを取得するには NameSpace オブジェクトの GetSharedDefaultFolder メソッドを使用します。
このメソッドで取得した Folder オブジェクトの Items に含まれるすべてのアイテムについて Excel ファイルへ受信日時などをエクスポートすればご要望は満たせるでしょう。

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

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

Public Sub ExportInboxInSharedMailboxToExcel()
     ' 共有メールボックスのメールアドレスを指定
     Const SHARED_MAILBOX = "shared1@example.com"
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\sharedmail.xlsx"
     ' Excel ファイルに書き出す本文の最大文字数
     Const MAX_BODY_CHARS = 250
     '
     Dim recOther As Recipient
     Dim fldOtherInbox As Folder
     Dim objBook
     Dim objSheet
     Dim objItem 'As MailItem
     Dim r As Integer
     ' 共有メールボックスの受信トレイを開く
     Set recOther = Session.CreateRecipient(SHARED_MAILBOX)
     Set fldOtherInbox = Session.GetSharedDefaultFolder(recOther, olFolderInbox)
     ' 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
     ' 共有メールボックスの受信トレイのすべてのアイテムについて処理
     For Each objItem In fldOtherInbox.Items
         ' メールの情報を Excel ファイルに追記
         With objSheet
             .Cells(r, 1) = objItem.ReceivedTime
             ' 差出人の名前にアドレスが含まれない場合のみアドレスを追加
             If InStr(objItem.SenderName, objItem.SenderEmailAddress) = 0 Then
                 .Cells(r, 2) = objItem.SenderName & _
                     " <" & objItem.SenderEmailAddress & ">"
             Else
                 .Cells(r, 2) = objItem.SenderName
             End If
             .Cells(r, 3) = objItem.Subject
             .Cells(r, 4) = Left(objItem.Body, MAX_BODY_CHARS)
         End With
         r = r + 1
     Next
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub


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