outlookからメールと添付ファイルを抽出するVBScriptを作ってみた

会社ではメーラとして outlookを使っている。
個人的には検索のアホさを始めとした、もろもろの使い勝手の悪さに辟易しているが、会社の標準なので付き合わざるを得ない。

特に最近面倒くささを感じていたのがメールのダウンロード（抽出）だ。エクスプローラにドラッグ＆ドロップすればメールファイル（msgファイル）が作成されるのだが

• 添付ファイルは個別にコピペする必要がある。
• msgファイルの名称がメール件名となるので、返信を繰り返したメールだと全て同じファイル名になり、いちいちリネームする必要がある。
• ファイル名を見ただけでは受信日時がわからない

といった不満がある。多分 outlookマクロを作成すれば解決できるのかも知れないが、会社では勝手にマクロを組み込むのは不可である。

いろいろとググってみると、VBScriptでも outlookの操作が可能のようである。VBScriptは Windowsで動作するスクリプト言語で個人的には全く馴染みがないが、

• Windowsであれば、何の事前準備も不要でダブルクリックで実行できる
• Officeの操作も可能
• 細かな文法やテクニックを知らなくても、Web上で公開されているコードを組み合わせれば何とかなりそう

という点がメリットである。

と言うことで、休み時間などを利用して半月ほどで一通り使えそうなものができたので、公開することにした。

まず、仕様は自分の好みで以下とした。

• outlook上の特定メールフォルダに格納されているメールを抽出対象とする。従って、抽出前に対象メールを「特定メールフォルダ」にコピーする必要がある。outlook上で対象メールを右クリックして抽出できれば一番良いのだが、これは VBScriptを使う限りは無理だと思う。
  【2019年5月2日追記】
  抽出対象メールを、「特定メールフォルダに格納されているメール」から「outlookで選択されているメール」に改良したバージョンを作成したので、興味のある方は本記事の文末を参照。
• msgファイルだけを抽出するか、添付ファイルも抽出するかを選択可能とした。
• 抽出した msgファイルの名称は「YYYYMMDD_HHMMSS_件名.msg」となる。ここで、YYYYMMDD_HHMMSSはメールの受信日時である。
• 添付ファイルは、「A_YYYYMMDD_HHMMSS_件名」という名称のサブフォルダの下にオリジナルのファイル名で格納される。頭の「A_」はスクリプトの15行目で定義しており変更可能である。
• メール件名には使えるが Windowsのフォルダ名には使えない特殊記号「?:/\*"<>|」は全角文字に変換される。

以下、本スクリプトを使った、outlookからメール（msgファイル）と添付ファイルを抽出する手順である。

1. 対象メールを outlookの受信フォルダ直下の「export」フォルダにコピーする。このメールフォルダ名はスクリプトの12行目で定義しており変更は可能だが、事前に決めて作成しておく必要がある。
2. 本スクリプトをダブルクリックで実行する。
3. 以下のダイアログが表示されるので、抽出先（格納先）フォルダを選択する。なお、ダイアログの下の「フォルダー(F):」にフルパスを直接貼り付けても良い。
   
   
   
   
4. 「添付ファイルを取り出しますか？」というダイアログが表示されるので「はい」「いいえ」のいずれかのボタンをクリックする。
   「いいえ」を選択した場合は msgファイルのみ、「はい」を選択した場合は msgファイルに加え添付ファイルも抽出される。なお、いずれの場合も、元が添付ファイル付きメールの場合、抽出された msgファイルを開けば添付ファイルも含まれている。
5. outlookへのアクセス許可を求める以下のダイアログが表示されるので、「許可」を選択する。
   

これで指定した抽出先フォルダに msgファイルや添付ファイルが格納される。

テストした環境は Windows7と Office2010の組合せのみなのであしからず。
スクリプト（コードはSJIS）は以下のリンクからご自由に。（右クリックして保存）
　⇒　改良版を作成したので原則そちらを利用していただきたい。文末の【2019年5月2日追記】参照。

「outlook2msg.vbs」をダウンロード

読みにくいが、内容は以下の通り。
なお、姉妹編として、メールの件名や内容の一覧をExcelに貼り付けるVBスクリプトも公開したので、興味のあある方はココへ。

---

Option Explicit

Dim objOA, objNS, objOLFolder, objShell, objFolder, objFSO, objItm, objAtt
Dim MyDate, MyFileName, MyFolder, MySubFolder, MyMsgPath, MyYesNo

Const olFolderInbox = 6
Const olMSG = 3
Const ErrNoOLFolder = -2147221233
Const ErrReject = -2147467260

'outlook の対象フォルダ名（受信トレイの下）
Const oLFolderName = "export"

'添付ファイル格納サブフォルダ名の接頭語
Const PreWord = "A_"

Set objOA = CreateObject("Outlook.Application")
Set objNS = objOA.GetNamespace("MAPI")

Err.clear
On Error Resume Next

Set objOLFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(oLFolderName)

If (Err.Number = ErrNoOLFolder) Then
MsgBox "指定した outlook のフォルダ " & oLFolderName  & " が存在しません"
WScript.Quit
End If

On Error Goto 0

Set objShell = WScript.CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder( 0 , "フォルダを選択して下さい" , &h4050 , &h11)

If (objFolder Is Nothing) Then
WScript.Quit
End If

MyFolder = objFolder.Items.Item.Path
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If Not(objFSO.FolderExists(MyFolder)) Then
MsgBox("存在しないフォルダが指定されました")
WScript.Quit
End If

MyYesNo = MsgBox("添付ファイルを取り出しますか？", vbYesNoCancel)
If MyYesNo = vbCancel Then
WScript.Quit
End If

For Each objItm In objOLFolder.Items

MyDate = objItm.ReceivedTime
MyDate = Replace(MyDate, "/", "")
MyDate = Replace(MyDate, ":", "")
MyDate = Replace(MyDate, " ", "_")

MyFileName = MyDate & "_" & objItm.Subject

'使用禁止文字を置換する
MyFileName = Replace(MyFileName, "?", "？")
MyFileName = Replace(MyFileName, ":", "：")
MyFileName = Replace(MyFileName, "/", "／")
MyFileName = Replace(MyFileName, "\", "￥")
MyFileName = Replace(MyFileName, "*", "＊")
MyFileName = Replace(MyFileName, """", "”")
MyFileName = Replace(MyFileName, "<", "＜")
MyFileName = Replace(MyFileName, ">", "＞")
MyFileName = Replace(MyFileName, "|", "｜")

MyMsgPath= MyFolder & "\" & MyFileName & ".msg"

Err.clear
On Error Resume Next

objItm.SaveAs MyMsgPath , olMSG

If (Err.Number = ErrReject) Then
  MsgBox "終了します"
  WScript.Quit
End If

On Error Goto 0

If (MyYesNo = vbYes) and (objItm.Attachments.count > 0) Then

  MySubFolder = MyFolder & "\" & PreWord & MyFileName

  If objFSO.FolderExists(MySubFolder) = True Then
   MsgBox "フォルダ " & MySubFolder & " は既に存在しています。"
  Else
   objFSO.CreateFolder(MySubFolder)
  End If

  For Each objAtt In objItm.Attachments
   objAtt.SaveAsFile MySubFolder & "\" & objAtt.DisplayName
  Next

End If

Next

---

【2019年5月2日追記】

以下の改良を行ったバージョンをアップしたので、興味のある方は ココへ。

• 対象メールを「outlookの特定メールフォルダ下にあるメール」から「outlook上で選択されているメール」に変更
• 添付ファイル抽出と同時に、元のメールの添付ファイルを削除するオプションを追加