メールデータ解析のため、Outlookの分類フォルダをまたいでメッセージを一括テキスト変換

　Outlookのマクロ（VBA）に関するエントリです。

　オライリーの『入門機械学習』はRによる機械学習の教科書で、正直どっちかというと今は「同じタイトルでPythonによる分析の教科書」の方が欲しい感じなのですが、これもけっこう写経しているだけでも勉強になります。

作者: Drew Conway,John Myles White,萩原正人,奥野陽,水野貴明,木下哲也
出版社/メーカー: オライリージャパン
発売日: 2012/12/22
メディア: 大型本
購入: 2人クリック: 41回
この商品を含むブログ (11件) を見る

　代表的な機械学習モデルの基本的な処理が一通り解説されており、実際にサンプルデータを使って一からコードを書いて分析を進めていくという内容で、前処理から順番に「こういうところでこういう問題が起きるだろ？だからこうやって解決するんだぜ」みたいな感じになっており、プロジェクトを進行させていくノリで書かれていて面白いです。
　それで、この教科書の最初の演習は、ナイーブベイズ分類器によるスパムメールの検出になってるのですが、これを読むとなんか「自分のメールを練習台にして色々分析してみたい」という気になってきます。

　ところで、メールボックスに溜まっているメールのデータを解析しようと思ったら、とりあえずテキストファイルでメール１通１ファイルみたいなデータが欲しいところです（区切りがハッキリしていれば１つのテキストファイルにつなげて書いてあっても良いですが）。
　『入門機械学習』でも、１通１ファイルのテキストファイルを使って分析を進めていました。

　それで、Windowsのパソコンで使っているOutlook2010内のメールデータを、どうやって吐き出そうかと考えました。Gmailのデータでもやってみたいですが、それは別途考えることに。
　一応、Outlookでメールボックスを開き、メッセージを全選択して「ファイル」→「名前を付けて保存」でTXT形式を選択すると、メッセージ全件が１つのテキストファイルにまとまったものを出力することができます。
　しかしこの方式だと、出力されたテキストファイル中でメールの区切りが厳密に判定するのが無理そうでした。また、私の場合メールボックスのフォルダ分類を細かくやりすぎて大変なことになってるので、全部やるのがめんどくさい。
　そこで、メッセージを「１通１ファイル」にして吐き出すマクロを書くことにしました。といっても私はVBAをほとんど触ったことが無いので*1、ググって色々参考にしながら作業しました。
　以下、ディスク上の保存先フォルダとの混同を避けるため、Outlookアプリ上に表示されるメールボックスの「フォルダ」は「ボックス」と呼ぶことにします*2。

　１つのメールボックスの中身を、１通１ファイルで出力するだけなら、↓の知恵袋で紹介されているコードが使えます。
Outlookの複数のメールを、ワードファイルまたはテキストファイルとして... - Yahoo!知恵袋

　しかし私はかなりたくさんのボックスに、しかも階層的にメッセージを保存しているので、その全体を再帰的に掘れるようなマクロじゃないと使えません。そこでさらにググって見つけた、

選択したフォルダーとそのサブフォルダーのすべてのアイテムを MSG ファイルとして保存するマクロ | Outlook 研究所

　このページで紹介されているマクロを使わせて頂くことにしました。写経してたら少しだけVBAの雰囲気を感じ取ることができました。
　これはmsgファイルとして保存するコードだったんですが、これを少し改変して使いました。

　上記サイトのコードだと、保存フォルダを１つ決めてパスをコード中に書き込んでおき、Outlook上でボックスを選択してこのマクロを実行すれば、選択中（アクティブ）のボックスに属しているフォルダやメールが、その階層構造を保ったまま、保存フォルダに記録されます。
　メール１件を「日付_時刻_件名」という形式のファイルにする処理や、ボックスの階層を再帰的にたどっていく処理を書いてくれているので、大変助かります。　
　
　
　ただ私の場合、10年分ぐらいのメールが、いくつものOuotlookメール保存データファイル（pstファイル）に分けて記録されていて、それぞれを開くとまたいくつものボックスに分かれています。上記のコードでやる場合、pstファイルの単位で保存先のフォルダを定義し、いちいちコード中に書き込んでから実行しなければならない。
　それだとちょっと手間なので、

Outlookでpstファイルを開いた状態でpstファイル（を表すメールボックス名）を選択する
マクロを実行する
選択したメールボックス名と同名のフォルダを、保存フォルダ内に生成する
生成したフォルダの中に、メールのデータを、メールボックスの階層構造に従って記録していく

　といったことがやりたい。
　そこで結論としては、上記サイトのマクロに、

"olMSG"（msgファイル形式を表す）をolTXT（txtファイル形式を表す）に変更
ファイル命名時の拡張子を".msg"から".txt"に変更
選択中のメールボックスの名前を取得して、その名前のフォルダを生成し、それを保存フォルダとする

　という変更を加えました。
　あと、元サイトのコードでは「Dim objItem As MailItem」の部分のAs以下がコメントアウトされてましたが、たぶん間違いなので「'」を取りました。コメントアウトしてあっても、方がvariant型になるだけで、マクロ自体は正常に動きますが。
　コードは以下のとおりです。コメントは私が細かく付しましたが、なんか見づらくなりました。

【追記】
　保存先のフォルダを、GUIで対話的に選択できるように、コードを追加しました。
　Outlook自身はFileDialogメソッドをサポートしていないので、裏でExcelを起動してダイアログを表示させ、選択したフォルダのパスを取得してExcelを終了するというルーチンを追加することになります。
　前提として、VBEの「ツール→参照設定」で、「Microsoft Excel 14.0 Object Library」を参照可能にしておかないと、上手く動きません。
　コードは以下のページを参考にしました。
マクロ実行中にフォルダーを選択・指定してもらう－FileDialog(msoFileDialogFolderPicker):エクセルマクロ・Excel VBAの使い方
 Outlook: FileDialog object error - Microsoft Community

　メインのルーチンから、「ダイアログで保存先フォルダを選択させる」ルーチンと、「選択中ボックス内のアイテムを再帰的に掘ってテキストファイルとして保存先フォルダに保存していく」ルーチンを、順番に呼び出していますが、前者において、ユーザがキャンセルボタンを押して選択を中止した場合の処理を書く必要があります。このとき、選択用ルーチン（Private Function）内でExit Functionするだけだと、呼び出し元は停止しないで、後者の保存用ルーチンが実行されてしまい、実際やってみたらDドライブ直下に保存されるという動きになりました。
　なので、キャンセルボタンが押された場合は、呼び出し元のメインルーチンに対して停止信号となるような返り値を返してやり、メインルーチン自体をExitするようにしました。
【/追記】
　
　

' 以下は、メインのルーチン。
' ディスク上の保存フォルダを指定し、Outlookで選択中のメールボックス名を
' 取得して同名のフォルダを保存フォルダ内に生成した上で、選択中のメールボックス
' と保存先を引数として保存用ルーチンに処理を投げる。

Sub SaveMailsAsText()
	Dim Selected As String
	Selected = SelectFolder()      ' フォルダを選択させるルーチンを呼び出して返り値を取得

	If Selected = "::::STOP::::" Then  ' 停止信号を受け取ったら、このメインルーチンを停止
		Exit Sub

	Else
		Dim SAVE_PATH As String
		SAVE_PATH = Selected & "\"                                         ' パスの最後に\を付ける必要がある
		Dim objFSO As Object                                               ' ファイルシステムオブジェクトを入れる変数の宣言
		Set objFSO = CreateObject("Scripting.FileSystemObject")            ' ファイルシステムオブジェクトの生成
		objFSO.CreateFolder SAVE_PATH & ActiveExplorer.CurrentFolder.Name  ' 選択中のメールボックスと同名のフォルダを生成
		
		' 保存用ルーチンに処理を投げる
		SaveFolderRecursive ActiveExplorer.CurrentFolder, SAVE_PATH & ActiveExplorer.CurrentFolder.Name & "\"
		
	End If
	
End Sub


' 以下は、ダイアログを表示して対話的にフォルダを選択させ、パスを取得するルーチン。
' Outlook自体はFileDialogメソッドをサポートしていないので、裏でExcelを起動して、
' ExcelのFileDialogメソッドでパスを取得し、変数に格納した上で、ExcelをQuitする。
' 前提として、VBEのツール→参照設定でExcelオブジェクトライブラリを参照可にしておく必要がある。

Private Function SelectFolder() As String

	Dim strFolderPath As String               ' フォルダのパスを格納する変数
	Dim objSurrogate As Object                ' 裏で動くエクセルを受け取る変数
	Dim dlgFolder As Office.FileDialog        ' ダイアログを受け取る変数

	Set objSurrogate = New Excel.Application  ' Excelを起動
	objSurrogate.Visible = False              ' ユーザには見せない

	' エクセルから、フォルダを選択させるダイアログを起動
	Set dlgFolder = objSurrogate.Application.FileDialog(msoFileDialogFolderPicker)
    
	' キャンセルボタンがクリックされたら呼び出し元ルーチンに停止信号を送る
	If dlgFolder.Show = False Then

		SelectFolder = "::::STOP::::"  ' 適当に考えた停止信号

	Else

		' 選択されたフォルダーのパスを変数に格納
		strFolderPath = dlgFolder.SelectedItems(1)

		objSurrogate.Quit                      ' Excelを終了
		Set objSurrogate = Nothing             ' 参照の解除（不要？）
		MsgBox strFolderPath & "に保存します"  ' 確認メッセージの表示（OKを押させるだけ）

		SelectFolder = strFolderPath           ' Functionプロシージャは関数名に返り値を格納する

	End If

End Function


' 以下は保存用ルーチン。
' Outlook上での選択中メールボックスを受け取って、当該ボックス内のアイテムに
' ファイル名を付けて保存フォルダに保存していく。
' 最後の方に、「ボックス内のボックス（サブボックス）」に対してこのルーチン
' 自身を適用する入れ子構造が埋め込まれているので、ボックスの階層を再帰的に
' 辿っていくことができる。

Private Sub SaveFolderRecursive(objFolder As Folder, strSavePath As String)
	On Error Resume Next       ' エラーを無視
	Dim objItem As MailItem    ' メールアイテム用の変数を宣言
	Dim strFileName As String  ' 保存する際のファイル名用の変数を宣言
	Dim i As Integer           ' ループのカウンター用の変数を宣言
	Dim arrErrChars            ' ファイル名・パスに使えない文字一覧用の変数を宣言
	Dim objFSO                 ' ファイルシステム操作用の変数を宣言
	Dim objSubFolder As Folder ' Outlookのサブボックス取得用の変数を宣言
	arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")  ' ファイル名・パスに使えない文字
	Set objFSO = CreateObject("Scripting.FileSystemObject")            ' ファイルシステムオブジェクトの生成

	' 選択中ボックスを受け取って中味のアイテム一覧からforループ
	For Each objItem In objFolder.Items
		' 日時と件名からファイル名生成
		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

		' ファイル名が 260 文字を超えないように、左から250字を取る
		strFileName = Left(strSavePath & strFileName, 250)

		' 同一日時に同じ件名のメールがあるとファイル名が同じになるので、
		' 同名のファイルがすでにある場合は2～の連番を付けるというループ
		If objFSO.FileExists(strFileName & ".txt") Then
			i = 2
			While objFSO.FileExists(strFileName & "(" & i & ").txt")
				i = i + 1
			Wend
			strFileName = strFileName & "(" & i & ")"
		End If

		' ファイルをフォルダに保存する
		objItem.SaveAs strFileName & ".txt", olTXT
	Next

	' 選択中ボックス内のボックス（サブボックス=サブフォルダ）一覧にforループを適用し、
	' 各サブボックスに対してこのルーチン自身を適用するという、再帰的処理
	For Each objSubFolder In objFolder.Folders
		If Not objFSO.FolderExists(strSavePath & objSubFolder.Name) Then  ' 保存フォルダに同名フォルダがなければ
			objFSO.CreateFolder strSavePath & objSubFolder.Name           ' 保存フォルダにサブフォルダを作成
		End If
		SaveFolderRecursive objSubFolder, strSavePath & objSubFolder.Name & "\"  ' サブフォルダに同じ処理を適用
	Next

End Sub

　
　
使い方としては、

Outlookを起動する。
Alt + F11でVBAエディタを開き、新規プロジェクトの標準モジュールで上記コードを書き込んで保存する。
保存したいメールボックスを選択し、Alt + F8のあと上記プロジェクト名を選択して実行する。

　とするだけです。
　また、リボンのユーザ設定でボタンを割り当てればワンクリックで動かせるようになります。*3
　複数のpstファイルをまたいで一発で保存することもできるかもしれませんが、調べていません。とりあえず上記マクロを、pstファイルの数だけ実行するという対応にしました。中途半端ですが・・・。
　なお、添付ファイルは無視です。

　実際やってみたら、メールの数があまりにも多い（1万通以上とか）メールボックスの場合、途中から「ファイルアクセス権のエラーのため保存できません」というメッセージが出て1通も保存ができなくなってしまいました。原因はよく分かりません。ググったら、そのエラーは常住アプリが作用して起きることがあるとかいう曖昧なことしか分かりませんでした。
　良く分からなかったので、いったん強制終了し、アイテム数がきわめて多いメールボックスについては、サブボックス単位でマクロを適用していくことにしました。結果、そこそこ手間がかかりました…が、求めていた「１通１ファイルのテキスト」が手に入ったので、よかったです。

　私はVBAを（ましてやOutlookで）使ったことがほとんどありませんが、上記のような超短いコードを写経しただけでも、なんか心理的なハードルがとても下がりました。「どういうオブジェクトがあって、どういうプロパティとメソッドがあるかを覚えていけばいいのか～」と、こう書いてしまうと当たり前のこと過ぎてナンセンスな感想なのですが、でもほんとにそんな感じでした。あと、VBAに限りませんが、一行一行自分で理解して、コメントを付けていくってのがけっこう勉強になるなと思いました。

*1:しかもExcelじゃなくてOutlookだし

*2:VBAのコード中ではFolderとなりますが。

*3:どこかのタブを開いてボタンが並んでいるところの端の方を右クリックし、リボンのユーザ設定で、新しいグループを作成してから、そのグループにマクロを挿入し、適当に名前を付ける。