Outlookのフォルダ構成ごとメールを取り出す方法

Outlookのメールだけならドラッグ&ドロップすれば、Windowsのフォルダへコピー可能だが、フォルダ毎ドラッグしてもWindowsのファイルシステムへコピーすることはできない。

これを実現するにはマクロでコピーするしかない。こんなこと通常やる必要は全くないのだが、ボケた上役の命令でやる機会があったので一応記録を残しておく。

Outlookでマクロを有効にための事前準備は以下。

[ファイル]-[オプション]-[トラストセンター]で[トラストセンターの設定]を開く
[マクロの設定]で[全てのマクロに対して警告を表示する]以下を選択する。
Outlookを再起動する。
[Alt]+[F11]でVBAの画面を開く
VBA画面で[ツール]-[参照設定]で開く画面から[Microsoft Scripting Runtime]を探し、チェックし[OK]をクリックする。
VBA画面で[挿入]-[標準モジュール]をクリックする。

ここまでで、左側のパネルでModule1という箇所が選択され、右側のパネルにＶＢＡのプログラムが書けるようになるので、以下のプログラムをコピペする。

Dim objFSO As Scripting.FileSystemObject

Sub ExportOutlookFolders()
    Dim objFolder As Outlook.Folder
    Dim strFolderPath As String
    strFolderPath = SelectAnExportFolder()
    If strFolderPath = "" Then
        MsgBox "出力するフォルダを選択してください。", vbInformation + vbOKOnly, "フォルダ選択"
    Else
        Set objFSO = New Scripting.FileSystemObject
        Set objFolder = Outlook.Application.ActiveExplorer.CurrentFolder
        ExportAnOutlookFolder objFolder, strFolderPath
    End If
    Set objFolder = Nothing
    Set objFSO = Nothing
End Sub

Sub ExportAnOutlookFolder(ByVal OutlookFolder As Outlook.Folder, strFolderPath As String)
    Dim objSubFld As Outlook.Folder
    Dim objItem As Object
    Dim strPath As String
    Dim strFilePath As String
    Dim strSubject As String
    Dim strFilename As String
    Dim strRecievedTime As String
    Dim nCount As Long
    On Error Resume Next
    strPath = strFolderPath & "\" & ReplaceInvalidCharacters(OutlookFolder.Name)
    If Dir(strPath, 16) = Empty Then MkDir strPath

    nCount = 0

    For Each objItem In OutlookFolder.Items
        strSubject = ReplaceInvalidCharacters(objItem.Subject)
        If strSubject = "" Then
            strSubject = "notitle"
        End If
        strRecievedTime = Format(objItem.ReceivedTime, "yyyymmddhhnnss")
        strFilename = strRecievedTime & "_" & strSubject & ".msg"
        strFilePath = strPath & "\" & strFilename
        If objFSO.FileExists(strFilePath) Then
            nCount = nCount + 1
            strFilename = strRecievedTime & "_" & strSubject & " (" & nCount & ").msg"
            strFilePath = strPath & "\" & strFilename
        End If
        objItem.SaveAs strFilePath, olMSG
        
        DoEvents
    Next

    For Each objSubFld In OutlookFolder.Folders
        ExportAnOutlookFolder objSubFld, strPath
    Next
    Set OutlookFolder = Nothing
    Set objItem = Nothing
End Sub

Function SelectAnExportFolder() As String
    Dim objSelFolder As Object
    Dim objShell As Object
    Set objShell = CreateObject("Shell.Application")
    Set objSelFolder = objShell.BrowseForFolder(0, "Select a folder", 0, 0)
    If Not TypeName(objSelFolder) = "Nothing" Then
        SelectAnExportFolder = objSelFolder.self.Path
    End If
    Set objSelFolder = Nothing
    Set objShell = Nothing
End Function

Function ReplaceInvalidCharacters(Str As String) As String
    Dim objRegEx As Object
    Set objRegEx = CreateObject("vbscript.regexp")
    objRegEx.Global = True
    objRegEx.IgnoreCase = False
    objRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
    ReplaceInvalidCharacters = objRegEx.Replace(Str, "_")
    Set objRegEx = Nothing
End Function

VBScript
​x
 
Dim objFSO As Scripting.FileSystemObject​Sub ExportOutlookFolders()    Dim objFolder As Outlook.Folder    Dim strFolderPath As String    strFolderPath = SelectAnExportFolder()    If strFolderPath = "" Then        MsgBox "出力するフォルダを選択してください。", vbInformation + vbOKOnly, "フォルダ選択"    Else        Set objFSO = New Scripting.FileSystemObject        Set objFolder = Outlook.Application.ActiveExplorer.CurrentFolder        ExportAnOutlookFolder objFolder, strFolderPath    End If    Set objFolder = Nothing    Set objFSO = NothingEnd Sub​Sub ExportAnOutlookFolder(ByVal OutlookFolder As Outlook.Folder, strFolderPath As String)    Dim objSubFld As Outlook.Folder    Dim objItem As Object    Dim strPath As String    Dim strFilePath As String    Dim strSubject As String    Dim strFilename As String    Dim strRecievedTime As String    Dim nCount As Long    On Error Resume Next    strPath = strFolderPath & "\" & ReplaceInvalidCharacters(OutlookFolder.Name)    If Dir(strPath, 16) = Empty Then MkDir strPath​    nCount = 0​    For Each objItem In OutlookFolder.Items        strSubject = ReplaceInvalidCharacters(objItem.Subject)        If strSubject = "" Then            strSubject = "notitle"        End If        strRecievedTime = Format(objItem.ReceivedTime, "yyyymmddhhnnss")        strFilename = strRecievedTime & "_" & strSubject & ".msg"        strFilePath = strPath & "\" & strFilename        If objFSO.FileExists(strFilePath) Then            nCount = nCount + 1            strFilename = strRecievedTime & "_" & strSubject & " (" & nCount & ").msg"            strFilePath = strPath & "\" & strFilename        End If        objItem.SaveAs strFilePath, olMSG                DoEvents    Next​    For Each objSubFld In OutlookFolder.Folders        ExportAnOutlookFolder objSubFld, strPath    Next    Set OutlookFolder = Nothing    Set objItem = NothingEnd Sub​Function SelectAnExportFolder() As String    Dim objSelFolder As Object    Dim objShell As Object    Set objShell = CreateObject("Shell.Application")    Set objSelFolder = objShell.BrowseForFolder(0, "Select a folder", 0, 0)    If Not TypeName(objSelFolder) = "Nothing" Then        SelectAnExportFolder = objSelFolder.self.Path    End If    Set objSelFolder = Nothing    Set objShell = NothingEnd Function​Function ReplaceInvalidCharacters(Str As String) As String    Dim objRegEx As Object    Set objRegEx = CreateObject("vbscript.regexp")    objRegEx.Global = True    objRegEx.IgnoreCase = False    objRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"    ReplaceInvalidCharacters = objRegEx.Replace(Str, "_")    Set objRegEx = NothingEnd Function​​

ここまでが終わったら、

Outlookの画面に戻り、コピーしたいフォルダを選択する
VBAの画面に戻り、一番上の「ExportOutlookFolders」という関数にカーソルを合わせる。（下図のように上部に[General]と[ExportOutlookFolders]が選択されたらOK。）
その後、下図の左上、赤丸内の緑の再生ボタンをクリックすると、Windows側の出力先のフォルダ選択画面が表示されるので、選択するとフォルダ構成毎、Windows側にコピーされる。

プログラムとしては、「今Outlookで選択されているフォルダを、指定のフォルダに出力する」という処理を行っている。出力されるファイル名は「メールの受け取り時刻＋件名」になる。