outlookからメールと添付ファイルを出力する（その２）

以前の記事「outlookからメールと添付ファイルを抽出するVBScriptを作ってみた」で、outlookからメールと添付ファイルを取り出すVBScriptを紹介した。

そのバージョンでは、あらかじめ対象メールをoutlookの指定フォルダにコピーしておかなければならなかったが、今回、その改良版としてoutlook上で選択されたメールを対象とするように仕様変更したので紹介する。
なお、私が試した環境は、Windows7とoutlook2010の組合せのみである。

主な機能は以下の通りである。

• outlookのメールを、msgファイルとして、Windowsの指定フォルダに出力する。ファイル名は「YYYYMMDD_HHMMSS_メール件名.msg」で YYYYMMDD HHMMSS はメールの受信日時である。
• オプションで、メールの添付ファイルを同じフォルダ直下の「添付_YYYYMMDD_HHMMSS_メール件名」というフォルダの下に出力することも選択可能。更に、オプションで、添付ファイル出力後、メールの添付ファイルを削除し、代わりに「添付ファイルを出力したフォルダのパスを記載したテキストファイル（ファイル名「元の添付ファイルの保存先フォルダ.txt」）」をメールに添付することも可能。

使い方は、以下の通りである。
まず、事前準備として、本記事の最後に添付されている「export_from_outlook.vbs」を任意の場所に置いておく。
あとは、outlook上で対象メールを選択した状態で（複数選択可）、このファイルをダブルクリックするだけである。VBスクリプトなので、VBAと違いoutlookに組み込む必要はない。

ダブルクリック後の手順をもう少し説明する。

1. ダブルクリックすると「n 通のメールが選択されています。続けますか？」ときいてくるので「はい」を選択する。
2. 以下のダイアログが表示されるので、出力先（格納先）フォルダを選択する。なお、ダイアログの下の「フォルダー(F):」にフルパスを直接貼り付けても良い。
   
   
   
   
3. 「添付ファイルを取り出しますか？」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。
   「いいえ」を選択した場合は msgファイルのみ、「はい」を選択した場合は msgファイルに加え添付ファイルも抽出される。
4. 3で「はい」を選択した場合、「添付ファイルを削除しますか？」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。「はい」を選択した場合、元のメールの添付ファイルは削除されるので注意。
5. 4で「はい」を選択した場合、「保存先フォルダを記載したテキストファイルを添付しますか？」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。ここで「はい」を選択した場合、元の添付ファイルは削除されるが、代わりに添付ファイルを出力したフォルダのパスを記載したテキストファイルが添付される。なお、いずれの場合も、元が添付ファイル付きメールの場合、抽出された msgファイルには添付ファイルが含まれている。
6. outlookへのアクセス許可を求める以下のダイアログが表示されるので、「許可」を選択する。
   
    
   
   

手順は以上である。

以下がスクリプトである。

---

Option Explicit

Dim objOA, objSelection, objShell, objFolder, objFSO, objItm, objAtt, objWss, objTxt
Dim MyDate, MyFileName, MyFolder, MySubFolder, MyMsgPath, YNCont, YNExt, YNDel, YNRplc, ENVtmp, MyTmpTxt, MyMsg, MyCnt, I

Const olMSG = 3
Const ErrReject = -2147467260

'添付ファイル格納サブフォルダ名の接頭語
Const PreWord = "添付_"
'元の添付ファイルの保存先フォルダを記載した添付ファイル名
Const AttFileName = "元の添付ファイルの保存先フォルダ.txt"

Set objOA = CreateObject("Outlook.Application")

Set objSelection = objOA.ActiveExplorer.Selection
If objSelection.Count = 0 Then
 MsgBox "メールが選択されていません。"
 WScript.Quit
Else
 YNCont = MsgBox(objSelection.Count & " 通のメールが選択されています。続けますか？", vbYesNo)
 If YNCont = vbNo Then
  WScript.Quit
 End If
End If

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

'MsgBox "MyFolder = " & MyFolder

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

MyCnt = 0
For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 If objItm.Attachments.count > 0 Then
  MyCnt = MyCnt + 1
 End If
Next

YNExt = vbNo
If MyCnt > 0 Then
 YNExt = MsgBox("添付ファイルを取り出しますか？", vbYesNoCancel)
 If YNExt = vbCancel Then
  WScript.Quit
 ElseIf YNExt = vbYes Then
  YNDel = MsgBox("添付ファイルを削除しますか？", vbYesNoCancel)
  If YNDel = vbCancel Then
   WScript.Quit
  ElseIf YNDel = vbYes Then
   YNRplc = MsgBox("保存先フォルダを記載したテキストファイルを添付しますか？", vbYesNo)
   If YNRplc = vbYes Then
    MyMsg = "★★警告★★" & vbCrLf & "以下のメールの添付ファイルが置き換えられます。良いですか？"
   Else
    MyMsg = "★★警告★★" & vbCrLf & "以下のメールの添付ファイルが削除されます。良いですか？"
   End If
   MyCnt = 0
   For I = 1 To objSelection.Count
    set objItm = objSelection.Item(I)
    If objItm.Attachments.count > 0 Then
     MyCnt = MyCnt +1
     MyMsg = MyMsg & vbCrLf & Right(Space(5) & MyCnt, 5) & ": "& objItm.Subject
    End If
   Next
   If MsgBox(MyMsg, vbYesNo) = vbNo Then
    WScript.Quit
   End If 
  End If
 End If
End If

Set objWss = WScript.CreateObject("WScript.Shell")
ENVtmp = objWss.expandEnvironmentStrings("%TMP%")

For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 
 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"
 
' MsgBox MyMsgPath
 
 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 (YNExt = 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.FileName
  Next
  
  If YNDel = vbYes Then
   Set objAtt = objItm.Attachments
   While objAtt.Count > 0
    objAtt.Remove 1
   Wend
   '既読に変更
   objItm.UnRead = False
   '変更を保存
   objItm.Save
   
   If YNRplc = vbYes Then
    MyTmpTxt = ENVtmp & "\" & AttFileName
    Set objTxt = objFSO.OpenTextFile(MyTmpTxt, 2, true)
    objTxt.Write(MySubFolder)
    objTxt.Close
    objItm.Attachments.Add(MyTmpTxt)
    objItm.Save
    objFSO.DeleteFile MyTmpTxt, True
   End If
  End If
 End If
Next

---

ファイルのダウンロードは以下のリンクを右クリックで「保存」を選択（ファイルの文字コードは SJIS）

ダウンロード - export_from_outlook.vbs

どうぞご自由に。