以前からOutlookのフォルダ構成のままにメールをmsgファイルとして一括でバックアップ取りたいと考えてました。やる気出してやってみたら意外とすぐできました。
私はメールの下書きにいろいろメモするのが習慣になっています。
なんせすぐ忘れるのでメモが必須です。メモを見れば思い出せます。
たまにAndroidのOutlookで編集すると本文が真っ白になったり画像が消えてしまったりすることもあり、月一くらいで全バックアップを取りたいと考えていました。スマホで編集しなければ変なことにはならないんですがやはりスマホで編集するのは手軽で良いんです。
■動作内容
Outlookで以下のようなフォルダ構成だったとします。
ローカルに以下の様にフォルダを作成し、メールは「年月日＿時分秒＿件名.msg」で保存します（アンダーバーは半角です）
・「受信トレイ」、「送信済みアイテム」は私の場合はバックアップ不要なので対象外にするフォルダも複数指定できるようにします。
・日時と件名が同じメールがあることもあるのでその場合、２個目以降のファイルには「年月日＿時分秒＿件名 (2).msg」「年月日＿時分秒＿件名 (3).msg」...と数字を付けてファイル保存します。
■VBAソース
'************************************************************** '* モジュール名： '* 概要：メールをmsgファイルに保存 '* 備考： '*************************************************************** Option Explicit Private Const OUTPUT_FOLDER = "c:\tmp\" ' 出力先 Private Const NOT_OUTPUT_FOLDER = "受信トレイ,PersonMetadata,送信済み,送信済みアイテム,連絡先,同期の問題,削除済みアイテム" '対象外フォルダをカンマ区切りで記載 Private fso As FileSystemObject Private oNotOutputFolder As Dictionary ' 対象外フォルダのDictionary Private Const REMOVE_STR = "[\\/:*?""'<>|]" ' パスから除去する文字列 '************************************************************** '* 関数名：Main_MailOutput '* 概要：メールをmsgファイルに保存 '* 使い方： '* パラメータ ：(I) なし '* 戻り値 ：なし '*************************************************************** Public Sub Main_MailOutput() Dim objOutlook As Outlook.Application Dim oNsp As Outlook.NameSpace Dim i As Long Dim sPath As String Dim sNotOutputFolder() As String Debug.Print vbCrLf & Now & " " & "処理開始" Set fso = New FileSystemObject Set objOutlook = New Outlook.Application Set oNotOutputFolder = New Dictionary Dim sMsg1 As String Dim sTargetMail As String Dim s1 As String ' 対象外フォルダのDictionary作成 sNotOutputFolder = Split(NOT_OUTPUT_FOLDER, ",") For i = LBound(sNotOutputFolder) To UBound(sNotOutputFolder) oNotOutputFolder.Add sNotOutputFolder(i), sNotOutputFolder(i) Next i ' Namespaceオブジェクトを取得 Set oNsp = objOutlook.GetNamespace("MAPI") '[ メールボックスへのループ ] For i = 1 To oNsp.Folders.count Debug.Print oNsp.Folders.item(i).Name 'メールアドレスが取得できる。 sMsg1 = sMsg1 & i & "：" & oNsp.Folders.item(i).Name & vbCrLf Next i ' 出力対象のメールを選択させる s1 = InputBox("出力対象メールの番号を入力してください" & vbCrLf & vbCrLf & sMsg1) If s1 = "" Then Exit Sub End If ' 出力するメールアドレス sTargetMail = oNsp.Folders.item(s1) '[ メールボックスへのループ ] For i = 1 To oNsp.Folders.count Debug.Print oNsp.Folders.item(i).Name 'メールアドレスが取得できる。 ' バックアップ処理を実施するメールアドレスの場合 If oNsp.Folders.item(i).Name = sTargetMail Then ' フォルダーパス作成 sPath = OUTPUT_FOLDER & oNsp.Folders.item(i).Name ' フォルダが無いなら作る If fso.FolderExists(sPath) = False Then fso.CreateFolder sPath End If ' フォルダ毎にローカルフォルダ作成、メール出力 Call MakeFolder(oNsp.Folders.item(i).Folders, sPath) End If Next i Debug.Print Now & " " & "処理終了" MsgBox "処理完了", vbInformation End Sub '************************************************************** '* 関数名：MakeFolder '* 概要： '* 使い方： '* パラメータ ：(I)oFolder フォルダーオブジェクト '* (I)sFolder ローカルフォルダ作成用パス文字列 '* 戻り値 ：なし '*************************************************************** Private Sub MakeFolder(oFolder As Folders, ByVal sFolder As String) Dim i As Long Dim spath1 As String Dim sFolder2 As String '[ 引数フォルダー内のフォルダーに対してループ ] For i = 1 To oFolder.count Debug.Print oFolder.item(i).FolderPath & " " & oFolder.item(i).Items.count ' 対象外フォルダの場合、何もしない If oNotOutputFolder.Exists(oFolder.item(i).Name) = True Then Debug.Print "出力対象外フォルダ：" & oFolder.item(i).Name ElseIf oFolder.item(i).Items.count = 0 Then 'メール数0件フォルダは出力しない Debug.Print "メール０件なので出力対象外：" & oFolder.item(i).Name Else ' フォルダパス作成 sFolder2 = sFolder & "\" & RegExpReplace(oFolder.item(i).Name, REMOVE_STR, "") ' フォルダが無いなら作る If fso.FolderExists(sFolder2) = False Then fso.CreateFolder sFolder2 End If ' ' 多すぎるのは省くTODO 'If oFolder.item(i).Items.count < 50 Then ' todo Call MailOutput(oFolder.item(i), sFolder2) 'End If ' todo 'サブフォルダがある場合さらに再帰実行 If oFolder.item(i).Folders.count > 0 Then Call MakeFolder(oFolder.item(i).Folders, sFolder2) End If End If Next i End Sub '************************************************************** '* 関数名：MailOutput '* 概要： '* 使い方： '* パラメータ ：(I)oFolder フォルダーオブジェクト '* (I)sPathSave ファイル保存先 '* 戻り値 ：なし '*************************************************************** Private Sub MailOutput(oFolder As Folder, ByVal sPathSave As String) Dim i As Long, j As Long Dim item As MailItem Dim filepath As String '[ 出力対象フォルダー内のメールに対してループ ] For i = 1 To oFolder.Items.count ' メールの場合のみファイル保存 If oFolder.Items(i).Class = olMail Then ' メールを取得 Set item = oFolder.Items(i) ' 同じ年月日時分秒で同じ件名のメールがあった場合の対応 For j = 0 To 1000 ' 0：まずは同じ年月日時分秒で同じ件名のメールがない想定 If j = 0 Then ' ファイルパス作成 filepath = sPathSave & "\" & Format(item.ReceivedTime, "yyyymmdd_hhmmss") & "_" & RegExpReplace(item.Subject, REMOVE_STR, "") & ".msg" Else ' 括弧付のファイルパス作成 filepath = sPathSave & "\" & Format(item.ReceivedTime, "yyyymmdd_hhmmss") & "_" & RegExpReplace(item.Subject, REMOVE_STR, "") & " (" & j & ").msg" End If ' ファイルがないなら保存する If fso.FileExists(filepath) = False Then item.SaveAs filepath Exit For ' j ループ終了 End If If j = 1000 Then MsgBox "同じ年月日時分秒で同じ件名が1000件！ここには来ないはず" End If Next j End If Next i End Sub '************************************************************** '* 関数名：RegExpReplace '* 概要：正規表現置換 '* 使い方： '* パラメータ ：(I)文字列 '* ：(I)正規表現パターン '* ：(I)置換後文字列 '* 戻り値 ：変換後文字列 '*************************************************************** Private Function RegExpReplace(s1 As String, sPattern As String, sReplaceStr As String) Dim oRegExp As RegExp Set oRegExp = New RegExp oRegExp.Pattern = sPattern ' 正規表現パターン oRegExp.IgnoreCase = False ' 大文字小文字を区別 oRegExp.Global = True ' 複数マッチオン RegExpReplace = oRegExp.Replace(s1, sReplaceStr) ' 置換 End Function
■実行方法
①ソースをOutlookのVBAのModule1とかに貼り付けて保存します。
②VBAの参照設定で以下はチェックが必要です
・Microsoft Scripting Runtime
・Microsoft VBScript Regular Expression 5.5
③定数OUTPUT_FOLDERの出力先は自分の環境に合わせて変更します。
④定数NOT_OUTPUT_FOLDERで出力対象外のフォルダをカンマ区切りで指定します。
⑤マクロのMain_MailOutputを実行します。
⑥インプットボックスでバックアップ対象のメールの番号を入力します。
⑦完了まで待ちます。メール数によりますが大量にあると時間かかります。
「受信トレイ」、「送信済みアイテム」を入れるとバックアップサイズが1GBを超えたりします。
まずはちょっと試したいという人は117～120行目あたりのコメントアウトされている部分をアンコメントして実行してみてください。アイテムが多いフォルダの場合はフォルダのみ作られてバックアップ処理は実施されません。
再帰、連想配列、正規表現も出てきて結構テクニカルで楽しいプログラムになりました。
役に立ったらコメントでもいただけると喜びます。
