以前からOutlookのフォルダ構成のままにメールをmsgファイルとして一括でバックアップ取りたいと考えてました。やる気出してやってみたら意外とすぐできました。
私はメールの下書きにいろいろメモするのが習慣になっています。
なんせすぐ忘れるのでメモが必須です。メモを見れば思い出せます。
たまにAndroidのOutlookで編集すると本文が真っ白になったり画像が消えてしまったりすることもあり、月一くらいで全バックアップを取りたいと考えていました。スマホで編集しなければ変なことにはならないんですがやはりスマホで編集するのは手軽で良いんです。
■動作内容
Outlookで以下のようなフォルダ構成だったとします。
ローカルに以下の様にフォルダを作成し、メールは「年月日＿時分秒＿件名.msg」で保存します（アンダーバーは半角です）
・「受信トレイ」、「送信済みアイテム」は私の場合はバックアップ不要なので対象外にするフォルダも複数指定できるようにします。
・日時と件名が同じメールがあることもあるのでその場合、２個目以降のファイルには「年月日＿時分秒＿件名 (2).msg」「年月日＿時分秒＿件名 (3).msg」...と数字を付けてファイル保存します。
Option Explicit
Private Const OUTPUT_FOLDER = "c:\tmp\"
Private Const NOT_OUTPUT_FOLDER = "受信トレイ,PersonMetadata,送信済み,送信済みアイテム,連絡先,同期の問題,削除済みアイテム"
Private fso As FileSystemObject
Private oNotOutputFolder As Dictionary
Private Const REMOVE_STR = "[\\/:*?""'<>|]"
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
sNotOutputFolder = Split(NOT_OUTPUT_FOLDER, ",")
For i = LBound(sNotOutputFolder) To UBound(sNotOutputFolder)
oNotOutputFolder.Add sNotOutputFolder(i), sNotOutputFolder(i)
Next i
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
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
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
Call MailOutput(oFolder.item(i), sFolder2)
todo
If oFolder.item(i).Folders.count > 0 Then
Call MakeFolder(oFolder.item(i).Folders, sFolder2)
End If
End If
Next i
End Sub
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
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
End If
If j = 1000 Then
MsgBox "同じ年月日時分秒で同じ件名が1000件！ここには来ないはず"
End If
Next j
End If
Next i
End Sub
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行目あたりのコメントアウトされている部分をアンコメントして実行してみてください。アイテムが多いフォルダの場合はフォルダのみ作られてバックアップ処理は実施されません。
再帰、連想配列、正規表現も出てきて結構テクニカルで楽しいプログラムになりました。
役に立ったらコメントでもいただけると喜びます。
