nono’s blog

山歩き、仕事の事、中国の事

【Outlook VBA】選択したフォルダとそのサブフォルダ内の全てのメールをmsgファイルで保存してExcelファイルにも書き出すマクロ

Outlookで選択したフォルダと、そのサブフォルダ内の全てのメールについて、
msgファイルで保存して、さらにメールの内容をExcelファイルに書き出すマクロです。

<使い方>
OutlookVBAに下記のソースコードを貼り付ける
ソースコードの「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