選択したフォルダーとそのサブフォルダーのすべてのアイテムを MSG ファイルとして保存するマクロ

受信トレイのすべてのメッセージを MSG ファイルとして保存するマクロのコメントにて以下のご要望をいただきました。

---

こちらのマクロを利用させていただいています。
受信以外のフォルダのメールを、フォルダ階層ごと、msg形式で保存することは可能でしょうか。
たとえば

■受信トレイ
■作業一覧
├|>■今日やること
├|>■明日やること
└|>■来週やること

というような、フォルダ構成になっているとして、「作業一覧」フォルダ配下のフォルダを含めて
保存してあるメールを、すべてmsg形式でハードディスクに保存したいのです。

この様なことは可能でしょうか。ご存じでしたらご教授ください。

---

フォルダの階層ごと保存するというような処理は、再帰という方法で実現できます。
選択したフォルダーとそのサブフォルダーのフォルダー階層を維持したまま、すべてのアイテムを msg として保存するマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Sub SaveCurrentFolderAndSubToDisk()
    Const SAVE_PATH = "c:\temp\" ' 保存するフォルダのパス。最後に必ず \ をつける
    SaveFolderRecursive ActiveExplorer.CurrentFolder, SAVE_PATH
End Sub
' フォルダーのアイテムを再帰的に保存するルーチン
Private Sub SaveFolderRecursive(objFolder As Folder, strSavePath As String)
    On Error Resume Next
    Dim objItem 'As MailItem
    Dim strFileName As String
    Dim i As Integer
    Dim arrErrChars
    Dim objFSO
    Dim objSubFolder As Folder
    arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objItem In objFolder.Items
        ' ファイル名を受信日時と件名から作成
        strFileName = Format(objItem.ReceivedTime, "yyyymmdd_hhnn_") & objItem.Subject
        If Err.Number <> 0 Then
            ' エラーが発生したら受信日時ではなく最終更新日時とする
            strFileName = Format(objItem.LastModificationTime, "yyyymmdd_hhnn_") & objItem.Subject
            Err.Clear
        End If
        ' ファイル名として不適切な文字を _ に置き換える
        For i = 0 To UBound(arrErrChars)
            strFileName = Replace(strFileName, arrErrChars(i), "_")
        Next
        ' ファイル名が 260 文字を超えないようにする
        strFileName = Left(strSavePath & strFileName, 250)
        ' 同名のファイルがある場合の処理
        If objFSO.FileExists(strFileName & ".msg") Then
            i = 2 ' (2) から始める
            While objFSO.FileExists(strFileName & "(" & i & ").msg")
                i = i + 1
            Wend
            strFileName = strFileName & "(" & i & ")"
        End If
        ' ファイルをフォルダに保存
        objItem.SaveAs strFileName & ".msg", olMSG
    Next
    ' サブフォルダーを保存
    For Each objSubFolder In objFolder.Folders
        ' ディスク上にフォルダーが存在しなければ作成する
        If Not objFSO.FolderExists(strSavePath & objSubFolder.Name) Then
            objFSO.CreateFolder strSavePath & objSubFolder.Name
        End If
        SaveFolderRecursive objSubFolder, strSavePath & objSubFolder.Name & "\"
    Next
End Sub


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