はじめに

私は基本的にBeckyを使っていますが、O365を使うようになり、今までのデータをOutlookに移す必要が出てきました。調べてみると、結構大変なんですよね。
EMLファイルは直接Outlookに登録できないですし。（正確には登録できるけど、プレビューできない。）

それを有償で変換するソフトも沢山出ているのですが、疑い深い私はそれを使うのもって感じだったので、自分で作れないか調べてみました。
Google先生で調べてみると、VBSで作っているものが出てきます。
けどこの方法は、１件ずつ開いてインポートするので、かなり遅い・・・・。
海外まで検索すると、もうちょっと高速で動く方法が載っていたので、それを改造してみたので、今回皆さんに公開したいと思います。

前準備
プログラム
使い方
　まとめ

前準備

「Outlook Redemption」のDeveloper versionをダウンロード

Download Redemption

ダウンロードしたファイルを実行して、インストールします。

BeckyからのEMLへの一括変換は、「CircleBecky」のプラグインが便利です。

CircleBeckyの詳細情報 : Vector ソフトを探す！

プログラム

下記のプログラムをコピペして、適当な名前（例：imporrt-eml.vbs）にして保存します。

Dim objShell : Set objShell = CreateObject("Shell.Application")
Dim FSO : Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
Dim objFolder : Set objFolder = objShell.BrowseForFolder(0, "Select the folder", 0)
Dim oLog, fn

Set wFolder = FSO.GetFolder(objFolder.Items.Item.Path)
Set oOutlook = CreateObject("Outlook.Application")

' Log Setting
fn = FSO.getParentFolderName(WScript.ScriptFullName) & "\" & _
    FSO.GetBaseName(WScript.ScriptFullName) & "_" & _
    Year(Now()) & Right("0" & Month(Now()), 2) & Right("0" & Day(Now()), 2) & ".log"
If FSO.FileExists(fn) = False then
    Set oLog = FSO.CreateTextFile(fn)
Else
    Set oLog = FSO.OpenTextFile(fn, 8, True)
End If


If (NOT objFolder is nothing) Then

    Dim oBaseFolder : Set oBaseFolder = oOutlook.Session.PickFolder

    If NOT oBaseFolder Is Nothing Then

        oLog.WriteLine(Now() & " Start...")
        LoopFolder wFolder, oBaseFolder
        oLog.WriteLine(Now() & " Finish...")
        MsgBox "Import completed.", 64, "Import EML"

    Else
        MsgBox "Import canceled.", 64, "Import EML"
    End If

    Set Folder = Nothing
Else
  MsgBox "Import canceled.", 64, "Import EML"
End If

oLog.Close
Set oLog = Nothing
Set objFolder = Nothing
Set objShell = Nothing


Sub LoopFolder(in_wFolder, in_oFolder)

    Dim wSubFolder
    Dim i : i = 0
    Dim oFolder : Set oFolder = in_oFolder.Folders.Add(in_wFolder.Name) 

    For Each file In in_wFolder.files
        If LCase(Right(file.Name,4)) = ".eml" Then
            OpenEml oFolder,file 
            i = i + 1
        End If 
    Next

    For Each wSubFolder In in_wFolder.SubFolders
        LoopFolder wSubFolder, oFolder
    Next

    oLog.WriteLine(Now() & " " & in_wFolder.Name & ":" & i)

End Sub

Sub OpenEml( Folder, file ) 
    Set objPost = Folder.Items.Add(6)
    Set objSafePost = CreateObject("Redemption.SafePostItem")
    objSafePost.Item = objPost
    objSafePost.Import file, 1024
    objSafePost.MessageClass = "IPM.Note"
    Set utils = CreateObject("Redemption.MAPIUtils")
    PrIconIndex = &H10800003
        utils.HrSetOneProp objSafePost, PrIconIndex, 256, true 'Also saves the message
    i = i + 1
End Sub