【Outlook VBA】選択したフォルダとそのサブフォルダ内の全てのメールをmsgファイルで保存してExcelファイルにも書き出すマクロ
Outlookで選択したフォルダと、そのサブフォルダ内の全てのメールについて、
msgファイルで保存して、さらにメールの内容をExcelファイルに書き出すマクロです。
<使い方>
・OutlookのVBAに下記のソースコードを貼り付ける
・ソースコードの「1.」にmsgファイルを保存するフォルダのパスを記載する
・ソースコードの「2.」にメールの内容を書き出すExcelファイルのパスを記載する
・Outlookで処理したいフォルダを選択してマクロを実行する
<ソースコード>
Sub FolderAndSubToDiskAndExcel() '1.保存するフォルダのパスを記載する。最後に必ず \ をつける。 Const SAVE_PATH = "C:\OutlookVBA\OutlookVBA\" '2.書き込むExcelファイルのパスを記載する。 Const EXCEL_FILE = "C:\OutlookVBA\OutlookVBA.xlsx" '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 'メイン処理(再帰ルーチン)呼び出し FolderRecursive ActiveExplorer.CurrentFolder, SAVE_PATH, objBook, objSheet, r 'Excel ファイルを閉じる objBook.Close True MsgBox "完了" End Sub 'フォルダーのアイテムを再帰的に処理するルーチン Private Sub FolderRecursive(objFolder As Folder, strSavePath As String, objBook, objSheet, r) On Error Resume Next Dim objItem 'As MailItem Dim strFileName As String Dim strFolderName As String Dim strFolderNameAll 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 'アイテムがメールだったら処理 If TypeName(objItem) = "MailItem" Then 'ファイル名を受信日時と件名から作成 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 'ファイル名が 250 文字を超えないようにする strFileName = Left(strSavePath & strFileName, 250) '同名のファイルがある場合の処理 If objFSO.FileExists(strFileName & ".msg") Then i = 2 While objFSO.FileExists(strFileName & "(" & i & ").msg") i = i + 1 Wend strFileName = strFileName & "(" & i & ")" End If '1.ファイルをフォルダに保存 objItem.SaveAs strFileName & ".msg", olMSG '2.ファイル内容をExcelに書き込み With objSheet .Cells(r, 1) = objItem.ReceivedTime .Cells(r, 2) = objItem.SenderName .Cells(r, 3) = objItem.Subject .Cells(r, 4) = objItem.To .Cells(r, 5) = objItem.CC .Cells(r, 6) = objItem.Body .Cells(r, 7) = strSavePath End With r = r + 1 End If Next 'サブフォルダーを保存 For Each objSubFolder In objFolder.Folders 'フォルダ名を作成 strFolderName = objSubFolder.Name 'フォルダ名として不適切な文字を _ に置き換える For i = 0 To UBound(arrErrChars) strFolderName = Replace(strFolderName, arrErrChars(i), "_") Next 'ディスク上にフォルダーが存在しなければ作成する If Not objFSO.FolderExists(strSavePath & strFolderName) Then objFSO.CreateFolder strSavePath & strFolderName End If FolderRecursive objSubFolder, strSavePath & strFolderName & "\", objBook, objSheet, r Next End Sub