フォルダー内のすべてのメールの内容を Excel ファイルに書き出し、さらに MSG ファイルとして保存するマクロ

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

---

質問なのですが指定フォルダ（下書きフォルダ）にあるすべてのメールを上記のようにデータ化はできないのでしょうか？
いろいろやってみましたがわかりません可能であればデータ取得後にｍｇｓファイルをファイルネームの頭に連番を付けたうえでcドライブ下のフォルダに入れたいです
よろしくお願いします

---

もちろん、フォルダーのアイテムをすべて取得するようにすることも可能です。
以下は、現在開いているフォルダーにあるすべてのメールの情報を Excel ファイルに書き出し、さらに c:\temp に msg ファイルとして保存するマクロです。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportToExcelAndMSG()
    Const EXCEL_FILE = "c:\temp\リスト.xlsx"
    Const MSG_FILE_BASE = "c:\temp\メール No."
    Dim fldCurrent As Folder
    Dim objItem As MailItem
    Dim objBook 'As Excel.Workbook
    Dim objSheet 'As Excel.Worksheet
    Dim r As Integer
    Dim c As Integer
    ' 現在開いているフォルダーを取得
    Set fldCurrent = ActiveExplorer.CurrentFolder
    ' Excel ファイルを開く
    Set objBook = GetObject(EXCEL_FILE)
    objBook.Windows(1).Activate
    Set objSheet = objBook.Sheets(1)
    ' データがない行まで移動
    r = 2
    While objSheet.Cells(r, 1) <> ""
        r = r + 1
    Wend
    c = 1
    ' メールの情報を Excel ファイルに追記
    For Each objItem In fldCurrent.Items
        With objSheet
            .Cells(r, 1) = objItem.To
            .Cells(r, 2) = objItem.CC
            .Cells(r, 3) = objItem.Subject
            .Cells(r, 4) = objItem.Body
            .Cells(r, 5) = objItem.SenderName
        End With
        objItem.SaveAs MSG_FILE_BASE & c & ".msg", olMSGUnicode
        r = r + 1
        c = c + 1
    Next
    ' Excel ファイルを閉じる
    objBook.Close True
    MsgBox fldCurrent.Name & "のアイテムを保存しました。"
End Sub


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