OUTLOOKへ emlファイルを一括登録する

メーラをOUTLOOKへ統一するとのお達しが出たので、今までのメールをOUTLOOKへ移行しました

Mozilla Thunderbird から１メール、１ファイルとして EML形式のファイルを大量エクスポート
これをOUTLOOKへ入れる方法を探していたところ、よいサンプルを発見！！

Outlook でフォルダーに含まれる多数の EML ファイルを一括インポートする方法

こちらのスクリプトを改造して、サブフォルダまで対応するようにさせていただきました

下のソースをコピーしてファイル名 EML-Import.vbs として保存。
EMLファイルと同じフォルダに保存してダブルクリックで実行できるハズです。

実行して「Microsoft Outlook: 実行しようとした操作が失敗しました。オブジェクトが見つかりませんでした。」
と言われた場合は、Outlookの「受信トレイ」の中に、「インポート」という名前のフォルダーを作成しておいてくださいです。
「インポート」フォルダがないと動かないです。

'// eml ファイルを OUTLOOK に取り込むスクリプト
'//
'// 仕様：スクリプトを置いてあるフォルダにある .eml ファイルを対象
'//       サブフォルダ配下の .eml も対象とする
'//       OUTLOOK の「受信トレイ」のフォルダ「インポート」に取り込む
'//       取り込んだ .eml ファイルは削除する
'//       コマンドプロンプトから実行した場合は進捗状況を表示する
'//
'// 実行方法：スクリプトをダブルクリック、またはコマンドプロンプトから
'//           > cscript スクリプト名.vbs  で実行
'//


'//===================================================================
'// FileSystemObject
Const ForReading = 1    '// ファイルを読み取り専用として開きます。このファイルには書き込むことができません。
Const ForWriting = 2    '// ファイルを書き込み専用として開きます。
Const ForAppending = 8  '//ファイルを開き、ファイルの最後に追加して書き込みます。


'//===================================================================
'// オブジェクト準備
Dim FSO
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

Dim WSH
Set WSH = WScript.CreateObject("WScript.Shell")

Dim OutlookApp 
Set OutlookApp = WScript.CreateObject("Outlook.Application") 


'//===================================================================
'// OUTLOOK側インポートフォルダ設定
Const olFolderInbox = 6 
Dim fldImport 
Set fldImport = OutlookApp.Session.GetDefaultFolder(olFolderInbox) 
Set fldImport = fldImport.Folders("インポート")
fldImport.Display 


'//===================================================================
'// ログ準備 - ログはスクリプトと同じ場所に作成
'//          - ログファイル名は スクリプト名_年月日.log
Dim oLog, fn
fn = FSO.getParentFolderName(WScript.ScriptFullName) & "\" & _
     FSO.GetBaseName(WScript.ScriptFullName) & "_" & _
     Replace(Left(Now(),10), "/", "") & ".log"
If FSO.FileExists(fn) = False then
    Set oLog = FSO.CreateTextFile(fn)
Else
    Set oLog = FSO.OpenTextFile(fn, ForAppending, True)
End If


'//===================================================================
'// 開始
log "START:" & FSO.GetFolder(".").Name
Call LoopFolder( FSO.GetFolder(".") )


'//===================================================================
'// 終了
OutlookApp.ActiveExplorer.Close 
log "インポートは終了しました。"
oLog.Close
Set oLog = Nothing


'//===================================================================
'// emlファイル取り込み（サブフォルダも対象）
Sub LoopFolder(objFolder)
    Dim objSubFolder
    Dim objFile
    
    log "LOOP: " & objFolder
    
    '// ファイルを登録
    For Each objFile In objFolder.files
        '// 拡張子が .eml ならインポート処理
        If LCase(Right(objFile.Name,4)) = ".eml" Then
           OpenEml objFile 
        End If 
    Next
    
    '// フォルダがあれば再帰
    For Each objSubFolder In objFolder.SubFolders
        LoopFolder objSubFolder
    Next
End Sub


'//===================================================================
'// eml ファイルを開いてインポート
Sub OpenEml( emlFile ) 
    '// エラー無視
    On Error Resume Next 
    log  "OPEN EML: " & emlFile.Name
    
    '// メールが開いていたら閉じる 
    While Not OutlookApp.ActiveInspector Is Nothing 
        OutlookApp.ActiveInspector.Close 
        WScript.Sleep 500 
    Wend 
    
    '// eml ファイルを Outlook で開くコマンドを実行 
    WSH.Run "outlook /eml """ & FSO.getParentFolderName(emlFile) & _
        "\" & emlFile.Name & """" 
    
    '// Outlook 起動待ち 
    While OutlookApp.ActiveInspector Is Nothing 
        WScript.Sleep 500 
    Wend 
    
    '// メールフォルダ移動 
    OutlookApp.ActiveInspector.CurrentItem.Move fldImport 
    
    '// 取り込んだファイルは削除(エラーが発生していなければ）
    If Err.Number = 0 Then
        emlFile.Delete
    End If
End Sub 


'//===================================================================
'// ログ出力
Sub log(strMsg)
    '// エラー無視
    On Error Resume Next
    
    '// ログファイルに出力
    oLog.WriteLine(Now() & " " & strMsg)
    
    '// CSCRIPT なら ECHOで表示
    If LCase(Right(WScript.FullName, Len("cscript.exe"))) = "cscript.exe" Then
        WScript.Echo Now() & " " & strMsg
    End If
End Sub