Lotus NotesのメールをOutlookに変換して移行する

2018年、IBMの長きに渡って提供されてきたNotesがインドの企業に売却されて、事実上の終焉を迎えました。もとより、現代ではGoogle WorkspaceやMicrosoft365といったモダンな企業向けソリューションがある時代に於いて、Notesはあまりにも古い。また、レガシー資産が多数ある事で、移行できずにズルズルと引きずってしまう大企業もありました。

しかし、クローズドなNotesの開発ノウハウはすでに現代的なものではないので、ウェブアプリケーション等に移行し、メール等も国際標準のものへ移行すべきということで、過去にウェブ上の資料を元に作成し改良を加えた「NotesメールをOutlookに移行させるツール」の情報をまとめて置こうと思います。

※Google Workspaceへの移行の場合は、標準搭載のデータ移行サービスを利用してDomino 8.5.2のIMAPから移行が可能のようです。

図：起動してみた様子

今回作成したツール

• Notes to Outlook v5 - Microsoft Access 64bitで作成しています。

Access VBAにて作成しています。関連リンクにある様々な先人の方々のコードが残されており、これらを元に修正を加えて形にしています。利用する為には、使用するPCにNotesクライアントがインストールされていて、起動させておく必要があります。

Access 2016で動作確認していますので、持っていない人はAccess 2016 Runtimeをインストールしておくと動作させることが可能です。また、今回はOutlookをターゲットにしていますが、以下のエントリーを参考にGmailへインポートも可能です

※こちらのアプリは限定公開となっています

※2023年8月8日、Notesのアプリで使ってるDBのビューデータを引き抜くものを新たにExcelにて作成しました

Google Apps ScriptでGmail APIにてメールデータを変換して追加する【GAS】

VBAでLotus NotesのDB内ビュー全データを引き抜く

作成した理由

Microsoft365移行にともなって、Notesのメールのバックアップファイル類からOutlookへの移行について、情報システム部門からの解答は「出来ないので諦めてくれ」というにべもない解答が返ってきた事がきっかけ。実際にはウェブ上ではすでに多くの変換系のアプリや移行支援サービス等があったにも関わらず。

確かにこれらのサービスは有償で、中には怪しい中華系アプリみたいなものも多く手を出しにくいのも事実。しかし、事務系に於けるメールは色々な過去のやり取りや手法を残していた資産でもあるため、移行要望が強かった為、調べてみたところ、VBAでNotes自身を操作してEML形式に変換出来るのがわかったのでチャレンジして、実際に150名近くのメールボックスの移管に成功しました。

※ウェブのツールの多くはNSFファイルを直接OutlookのPSTというメールボックス形式に変換するものが多いのですが、実際の効果の程は不明です。

また、その後の調査によると、NotesのDBに対して、ODBCドライバ経由で接続させたり、メールだけじゃなく掲示板やカレンダー、タスクといったようなデータも取り出せるようです。

アプリの詳細

アプリケーションの仕様

本アプリケーションは以下のような仕様になっています。

• サーバ接続ではなくローカルに切り出したNSF形式のバックアップファイルを取り込んで取り出す仕組みです。
• 取り出したメールはEML形式で１通ずつ出力されます。
• デスクトップのtempnotesというディレクトリを自動作成してそちらに出力します。
• アドレス変換機能でNotes上の名称からSMTPのメールアドレスへ変換します。（○○@名前といった独自のアドレスのこと）
• 100%完璧な出力ではなく90%程度。Notes独自の通知メールであったり、lnk形式のショートカットの添付等についてはスルーする仕様です
• 変換にあたっておかしな特殊文字については、変換や置き換えを実行しています。
• メールは基本的には添付ファイル付きの場合は、一度取り出してから再構成しています。
• フォルダ分けをしていた場合には、それらも忠実に再現するように出力先にフォルダ単位でエクスポートするようになっています。但し、フォルダ名に使えないおかしな特殊文字についてはなるべく変換するようにしています。
• 事前に受信トレイ直下に「インポート」というフォルダを作成する必要があります。
• Outlookにアドオンを入れていると起動時にダイアログが表示されてしまい、処理が止まるので予めOutlookを起動してこれらのダイアログを閉じた状態でプログラムを利用する必要があります。
• メールサブジェクトは30文字でカットするようにしています（異常に長いとエラーになるため）

使い方

起動してVBAが有効な状態であるならば、「Notes to Outlook」というタブが開かれて、いくつかのコマンドがすでに表示されてると思います。これらを順番に実行していく事で、NSFファイルから取り込んで、Outlookの所定のフォルダに順番にインポートしてゆきます。ファイルの数によって処理時間は異なっていくので、大量にある場合には夜に実行するか？昼休みなどに実行すると良いでしょう。

プログラム設定

ここは使わなくても問題ないですが、Notesのメールのユーザ名を通常のメールアドレスに変換する場合に利用します。Notesは通常のSMTPとは異なりユーザ名で送信出来るようになってしまってるので、これらの名称をアドレスに変換してEMLファイルにする場合に利用します。

社員ID、社員名、メールアドレスの3つ入れておくだけです。

送信者アドレスはこのアプリで取り込み対象としてるメインのアカウントのメールアドレスを、プレフィックスにはNotesメール特有のhoge@yournameとなってるhogeの部分を入れて保存をクリックします。

図：氏名とアドレス変換テーブルです

Notesからデータ取り込み

Notesを自動的に起動しますが、キャンセルでOK。バックアップファイルとして切り出しているであろう、メールの塊のNSFファイルを指定します。NSFファイルの中から仕様にしたがって、所属フォルダの情報、メール本文、添付ファイル、メールアドレスなどを取り出して、フォルダ名リストの構築とデータをT_Mailテーブルに格納します。

添付ファイルもAccessの添付ファイル型のフィールドに複数格納してる状態になるので、Accessのファイルサイズの制限である2GBを超えないように注意する必要があります。そこまでメールボックスを割り当ててる企業は早々いないと思いますが。なお別のNSFファイルを取り込むとこれらのテーブルのデータはデリートされて洗い替えで取り込まれるので注意が必要です。

添付ファイル取り出し

この機能はメールを取り込むのではなく、所定のフォルダに添付ファイルだけを一括で取り出す機能になります。前述の作業の後に実行する事で、メールデータから添付ファイルのあるものを発見し、個別のファイルとして出力します。

通常は使わなくても良い機能です。

emlファイル生成

デスクトップのtempnotesというフォルダ内に、T_Mailの内容及びフォルダ名リストに従って、テーブルに取り込んだデータから、Outlookにインポート可能な個別のEML形式のファイルを生成します。Outlookはこの他MSG形式も取り込めるようになってるのですが、本アプリはEML形式でのみ出力します。

この段階ではまだOutlookに取り込んでいませんが、EML形式のファイルはBoxなどのクラウドストレージサービスでも対応してるため、アップロードすると検索インデックスの対象になり、全文検索が可能になるため、あえてOutlookにインポートせずにBoxにアップロードするという手段を取るのも手軽で利便性がアップします。ファイル自体はダブルクリックすると、デフォルトメーラーで直接開かれます。

取得済みデータ一覧

１つ目の手順でNotesのNSFから取り込んだ内容が詰まってるT_Mailテーブルの内容を閲覧可能にしてるだけのフォームです。通常は使わなくても問題ありませんが、どんな内容が取り込まれているのか？また、フィルタして不要なデータは削除してしまうといった事がこのフォーム上で可能です。

EML取り込み

tempnotesに出力されたEMLファイル及び、その中に生成されてるサブフォルダ内のEMLファイルまで走査して、Outlookの受信トレイ直下のインポートディレクトリ内に、インポートを行います。１通ずつオープンしてインポートするのでなかなか時間が掛かる作業です。

インポートにあたりエラーがなければ、取り込んだEMLファイルは順次削除されて、失敗したものだけがtempnotesフォルダに残るようになっています。

ソースコード

これらのコードはその殆どが関連リンク先で公開されてるコードを加工したものになります。VBSのコードをVBAに変換したものも含まれます。主要なコード部分だけを掲載しています。

受信トレイ以外のフォルダ構成を取得する

Public Function allNotesView(filepath As String)
    '変数を宣言
    Dim mailFile As String
    mailFile = filepath
    
    'DB接続用
    Dim dbs As DAO.Database
    Set dbs = CurrentDb
    Dim rs As DAO.Recordset
    Set rs = dbs.OpenRecordset("フォルダ名リスト", dbOpenDynaset)

    Dim session As Object, db As Object
    Dim server As String, notesDB As String
    Dim items As Variant, docs As Variant, views As Variant
    Dim view As Object, doc As Object, item As Object
    Dim i As Long
    
    Set session = CreateObject("Notes.NotesSession")
    server = ""
    notesDB = mailFile
    
    Set db = session.GetDatabase(server, notesDB)
    If Not db.IsOpen Then db.Open
    views = db.views
    For i = LBound(views) To UBound(views)
        'フォルダであったら、処理をする
        If Left(views(i).Name, 1) = "(" Then
            'ただのビューなので処理をしない
        Else
            With rs
                .AddNew
                !フォルダ名 = views(i).Name
                !出力先フォルダ名 = views(i).Name
                !delflg = 0
                .Update
            End With
        End If
    Next i
    
    '終了処理
    Set dbs = Nothing
    Set db = Nothing
    Set session = Nothing
    Set rs = Nothing
    
End Function

NSFからテーブルに取り込む

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As Long
Declare PtrSafe Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long

'優先順位クラスフラグ
Const HIGH_PRIORITY_CLASS = &H80&
Const IDLE_PRIORITY_CLASS = &H40&
Const NORMAL_PRIORITY_CLASS = &H20&
Const REALTIME_PRIORITY_CLASS = &H100&
'Notes EMBEDDEDOBJECTの種類
Const EMBED_ATTACHMENT = 1454
Const EMBED_OBJECT = 1453
Const EMBED_OBJECTLINK = 1452

Sub getMailSub(view As Object, statusman As String, expfolder As String, Optional subjectCriteria As String)
    'On Error GoTo Err_handler
    'エラーハンドリング用
    Dim result As Variant
    Dim errormsg As Variant

    '個々のメールの内容を取得する
    Dim AcDB As DAO.Database
    Dim items As Variant, docs As Variant
    Dim doc As Object, item As Object, RichTextBody As Object
    Dim i As Long, j As Long
    Dim b As Long
    Dim buf As Variant, attaches As Variant, attach As Object
    Dim useraddress As String
    
    'Access
    Dim rs As DAO.Recordset
    Dim myDate As Date 'strUpdateで重複チェック
    Dim strWhere As String 'Dcountのcriteria
    Dim subjectHitFlag As Boolean 'Subjectが検索対象文字列を含むか否かのフラグ
    Dim mySubject As String
    Dim FSO As New FileSystemObject
    Dim ret As Variant
    Dim bufcnt As Variant
    Dim tempaddress As Variant
    
    Dim destDrive As String
    destDrive = CreateObject("WScript.Shell").SpecialFolders.item("Desktop") & "\tempnotes\"

    Set AcDB = CurrentDb()
    Set rs = AcDB.OpenRecordset("T_mail")
    Set doc = view.getFirstDocument
    
    'Notesメールのレコード数を取得する
    Dim doccount As Variant
    Dim counter As Long
    counter = 1
    doccount = view.EntryCount

    'Notesメールのプレフィックス
    Dim prefix As String
    prefix = DLookup("prefix", "setting", "ID=1")
    
    '同じファイルが添付されるのを防ぐ為の変数
    Dim befattach As String
    Dim nowattach As String
    
    '添付ファイル名用
    Dim tempAttach As String
    Dim strsubject As Variant
    
    'プログレスバー標記用変数
    Dim varReturn As Variant

    Do Until doc Is Nothing
    
        'プログレス表示
        varReturn = Application.SysCmd(acSysCmdInitMeter, counter & "個目の" & statusman & "トレイのレコードを取込中．．．", doccount)
        
        subjectHitFlag = False
        'Subjectにより判断する
        On Error Resume Next
        buf = doc.getfirstitem("Subject").Values
        mySubject = buf(0)
        subjectHitFlag = True
        
        '不在通知の場合送信日付がないので現在の日付を便宜的に充てる
        If Left(mySubject, 4) = "不在通知" Then
            myDate = Now()
        Else
            '送信日の有無をチェック
            If doc.getfirstitem("PostedDate") Is Nothing Then
                myDate = Now()
            Else
                buf = doc.getfirstitem("PostedDate").Values
                myDate = buf(0)
            End If
        End If
        
        
        strWhere = "[strPosted] = " & "'" & CStr(myDate) & "'"
        '主キーが登録済みでなければAddNew。Updateは今後の課題
        Debug.Print DCount("[strPosted]", "T_mail", strWhere)
        'If DCount("[strPosted]", "T_mail", strWhere) = 0 And subjectHitFlag Then
        
        'Subjectは30文字にカットする
        strsubject = Left(mySubject, 30)

        rs.AddNew
        rs!strPosted = CStr(myDate)
        rs!PostedDate = myDate
        rs!Subject = strsubject
        
        'SendToがなく、BCCのみのメールが存在する
        If Not doc.getfirstitem("SendTo") Is Nothing Then
            buf = doc.getfirstitem("SendTo").Values
            
            'sendtoの件数を取得する
            bufcnt = UBound(buf) - LBound(buf) + 1
          
            '全部のsendtoをピックアップする
            For b = 0 To bufcnt - 1
              If Right(buf(b), 3) = prefix Then
                  'DLookupでまずテスト
                  tempaddress = DLookup("メールアドレス", "アドレス変換テーブル", "社員ID='" & Mid(buf(b), 4, 6) & "'")
              
                  '返り値がNullの時とそうでないときの処理
                  If IsNull(tempaddress) Then
                      'Null値なので、そのまま値を追加する
                      tempaddress = buf(b)
                  End If
              Else
                  tempaddress = buf(b)
              End If
            
              '2件目移行ならカンマを追加する
              If b > 0 Then
                  rs("SendTo") = rs("SendTo") & "," & tempaddress
              Else
                  'CC情報を追記する
                  rs("SendTo") = rs("SendTo") & tempaddress
              End If
            Next b
        End If
        
        'Fromアドレスを修正する
        buf = doc.getfirstitem("From").Values
        If Right(buf(0), 3) =  prefix Then
            'DLookupでまずテスト
            tempaddress = DLookup("メールアドレス", "アドレス変換テーブル", "社員ID='" & Mid(buf(0), 4, 6) & "'")
            
            '返り値がNullの時とそうでないときの処理
            If IsNull(tempaddress) Then
                'Null値なので、そのまま値を追加する
                rs!From = buf(0)
            Else
                'メールアドレスがあるのでメアドに変換
                rs!From = tempaddress
            End If
            
        Else
            rs!From = buf(0)
        End If

        rs!From = tempaddress
        If Not doc.getfirstitem("CopyTo") Is Nothing Then
            buf = doc.getfirstitem("CopyTo").Values
            
            'CCの件数を取得する
            bufcnt = UBound(buf) - LBound(buf) + 1

            '全部のCCをピックアップする
            For b = 0 To bufcnt - 1
                If Right(buf(b), 3) =  prefix Then
                    'DLookupでまずテスト
                    tempaddress = DLookup("メールアドレス", "アドレス変換テーブル", "社員ID='" & Mid(buf(b), 4, 6) & "'")
                
                    '返り値がNullの時とそうでないときの処理
                    If IsNull(tempaddress) Then
                        'Null値なので、そのまま値を追加する
                        tempaddress = buf(b)
                    End If
            
                Else
                    tempaddress = buf(b)
                End If

                '2件目移行ならカンマを追加する
                If b > 0 Then
                    rs!cc = rs!cc & "," & tempaddress
                Else
                    'CC情報を追記する
                    rs!cc = rs!cc & tempaddress
                End If
            Next b
        End If
        
        If Not doc.getfirstitem("BlindCopyTo") Is Nothing Then
            buf = doc.getfirstitem("BlindCopyTo").Values

            'CCの件数を取得する
            bufcnt = UBound(buf) - LBound(buf) + 1
            
            '全部のCCをピックアップする
            For b = 0 To bufcnt - 1
                If Right(buf(b), 3) = prefix Then
                    'DLookupでまずテスト
                    tempaddress = DLookup("メールアドレス", "アドレス変換テーブル", "社員ID='" & Mid(buf(b), 4, 6) & "'")
                
                    '返り値がNullの時とそうでないときの処理
                    If IsNull(tempaddress) Then
                        'Null値なので、そのまま値を追加する
                        tempaddress = buf(b)
                    End If
                Else
                    tempaddress = buf(b)
                End If
            
                '2件目移行ならカンマを追加する
                If b > 0 Then
                    rs!bcc = rs!bcc & "," & tempaddress
                Else
                    'CC情報を追記する
                    rs!bcc = rs!bcc & tempaddress
                End If
            Next b
            
        End If
        
        '送信フラグを設定する
        If view.Name = "($Sent)" Then
          rs!sendFlag = True
        Else
          rs!sendFlag = False
        End If
        
        '出力先フォルダ名を設定
        rs!出力先 = expfolder
        
        'Fromのアドレスがユーザアドレスと一致する時送信フラグを設定する
        Dim test As Variant
        test = DLookup("useraddress", "setting", "ID=1")
        
        If IsNull(test) Then
            test = ""
        Else
            
        End If
        
        If useraddress = "" Then
            '判定しない
            rs!sendFlag = False
        Else
            'ユーザアドレスと一致するか判定
            If rs!From = useraddress Then
                '一致するのでフラグを立てる
                rs!sendFlag = True
            Else
                '一致しないのでフラグを立てない
                rs!sendFlag = False
            End If
        End If
        
        Set RichTextBody = doc.getfirstitem("Body")
        'Bodyが無いメールがあるのでその対策を追加
        If Not RichTextBody Is Nothing Then
          rs!Body = RichTextBody.Text
          If doc.HASEMBEDDED Then
            attaches = Empty
            If IsArray(RichTextBody.EMBEDDEDOBJECTS) Then attaches = RichTextBody.EMBEDDEDOBJECTS
            If IsArray(attaches) Then
              For i = LBound(attaches) To UBound(attaches)
                'HTMLメールの画像は添付ファイルとして認識されないが、電子署名用のsmime.p7sは添付ファイルと認識される
                If attaches(i).Type = EMBED_ATTACHMENT Then '1454
                  Set attach = attaches(i)

                  'ファイル名がおかしいかどうかチェックする
                  tempAttach = replaceNGchar(attach.Name)
                  tempAttach = StrConvU(tempAttach, vbNarrow)
                  tempAttach = replaceUniChar(tempAttach)

                  '一時フォルダに添付ファイルを解凍する
                  attach.EXTRACTFILE destDrive & tempAttach
                  
                  '現在の添付ファイルの名前を格納
                  nowattach = tempAttach
                  
                  'Access2007からの添付ファイル型および複数の値を持つフィールドは、そのフィールドの中に
                  'レコードセットを保持している感じである。
                  
                  If FSO.GetExtensionName(tempAttach) = "lnk" Then
                    'ショートカットファイルなので添付をせずスルーする
                  Else
                      
                      '前の添付ファイル名と同じものの場合添付をスルーする（エラーになるため）
                      If nowattach = befattach Then
                        '直前の添付ファイル名と同じなので同じレコードには添付しない
                      Else
                        With rs.Fields("attach").Value
                          .AddNew
                           '.lnkファイルは 3058 インデックスまたは主キーには、NULL 値を使用できませんというエラーになる
                           'その他少数のファイルで、同様のエラーで添付できないものがあるが原因不明。
                          .Fields("FileData").LoadFromFile destDrive & "\" & tempAttach
                          .Update
                        End With
                        
                      End If
                      
                      '添付ファイル名を格納する
                      befattach = tempAttach
                      
                  End If

                  'ファイルを削除する
                  FSO.DeleteFile destDrive & tempAttach
                  If Err.Number <> 0 Then Debug.Print "Delete Err", tempAttach, Err.Number, Err.Description
                  Set attach = Nothing
                  
                End If
              Next i
              
              '添付ファイル情報をクリアする
              nowattach = ""
              befattach = ""

            End If 'isArray
          End If 'HASEMBEDDED
        End If 'RichTextBody
        DoEvents: DoEvents: DoEvents
        rs.Update
        'End If 'Dcount
        
        Set doc = view.GETNEXTSIBLING(doc)
        Sleep 10
        
        'インジケータの数値をアップ
        counter = counter + 1
        varReturn = Application.SysCmd(acSysCmdUpdateMeter, counter)
    
    Loop

    Set rs = Nothing
    Set FSO = Nothing
    Set AcDB = Nothing
    
    '終了処理
    Access.Application.SysCmd (acSysCmdRemoveMeter)
    Exit Sub

'エラー処理後に実行する
ExitProcedure:
    '問い合わせ
    result = MsgBox("エラー！！" & vbCrLf & errormsg & vbCrLf & "このままこのメールだけ処理をスキップして次に進むこともできます。進みますか？", vbYesNo + vbDefaultButton2 + vbExclamation)
    If result = vbYes Then
        '処理は継続されます
        On Error Resume Next
    Else
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If
    
'エラー発生時の処理
Err_handler:
    errormsg = "エラー番号:" & Err.Number & vbCrLf & "エラーの種類:" & Err.Description
    
    Resume ExitProcedure
    
End Sub

EMLファイルを生成する

Public Members() As Variant
Option Explicit
'emlファイルを作るルーチン
Private Sub CreateEmlFile(ByVal MailFrom As String, _
                          ByVal MailTo As String, _
                          ByVal MailCc As String, _
                          ByVal MailBcc As String, _
                          ByVal MailSubject As String, _
                          ByVal MailBody As String, _
                          ByVal MailPath As String, _
                          ByVal MailFileName As String, _
                          ByRef AttachArray() As Variant, _
                          Optional ByVal Charset As String = "UTF-8")
  Const adTypeText = 2
  Const adSaveCreateOverWrite = 2
  Dim testarr As String
  Dim arrlength As Long
  Dim i As Long
  Dim filepath As String
  
  On Error Resume Next
 
  With CreateObject("CDO.Message")
    .BodyPart.Charset = Charset
    .From = MailFrom
    .To = MailTo
    If Len(Trim(MailCc)) > 0 Then .cc = MailCc
    If Len(Trim(MailBcc)) > 0 Then .bcc = MailBcc
    .Subject = MailSubject
    .TextBody = MailBody
    
    '添付ファイルパスがある場合だけ処理
    testarr = AttachArray(1)

    If testarr = "NOFILE" Then
        '何もしない
    Else
        '配列の要素数をカウントする
        arrlength = UBound(AttachArray)
        
        For i = 1 To arrlength
            'ファイルのパスを取り出す
            filepath = AttachArray(i)
            'ファイルを添付する
            .AddAttachment filepath
        Next i
        
        '.AddAttachment AttachmentFilePath
    End If

    With .GetStream
      '.Charset = "UTF-8"
      .Charset = Charset
      .Type = adTypeText
      .SaveToFile MailPath & "\" & MailFileName, adSaveCreateOverWrite
    End With
  End With
End Sub

添付ファイルだけを取り出す

'添付ファイルだけを取り出すルーチン
Public Function attachexport()
    '変数の宣言
    Dim folpath As Variant
    Dim GetFolderName As String
    Dim reccnt As Long
    Dim FSO As New FileSystemObject
    Dim counter As Long
    Dim exportpath As String
    Dim v As Variant
    
    'プログレス用変数
    Dim varReturn As Variant

    '保存先フォルダの指定ダイアログの表示
    With Application.FileDialog(msoFileDialogFolderPicker)
      'ダイアログのタイトルを設定
      .Title = "添付ファイルの保存先の指定"
      'ダイアログを表示
      folpath = .Show
      If folpath <> 0 Then
        'フォルダが選択されたとき
        'そのドライブ名＋フォルダ名を返り値に設定
        GetFolderName = Trim(.SelectedItems.item(1))
      Else
        'フォルダが選択されなければ長さゼロの文字列を返す
        GetFolderName = ""
      End If
    End With
    
    'キャンセルされた場合の処理
    If GetFolderName = "" Then
        MsgBox "処理はキャンセルされました。"
        Exit Function
    End If
    
    'データベースに接続
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim rsf As DAO.Recordset
    Dim strSQL As Variant
    Set db = CurrentDb
    Set rst = db.OpenRecordset("T_mail")
    Set rsf = db.OpenRecordset("フォルダ名リスト", dbOpenDynaset)
    
    'レコード件数が0ならば処理を中止
    reccnt = rst.RecordCount
    If reccnt = 0 Then
        MsgBox "処理すべきレコードが0件でした"
        Exit Function
    End If
    
    '一時処理用変数
    Dim tempcc As Variant
    Dim tempbcc As Variant
    Dim tempsubject As Variant
    Dim tempAttach As Variant
    Dim attachman As Variant
    
    '指定の保存先に保存用フォルダの作成
    Do Until rsf.EOF
        'ファイルが存在する場合、ファイルを開く
        If FSO.FolderExists(GetFolderName & "\" & rsf!出力先フォルダ名) = True Then
            'フォルダはあるのでスルーする
        Else
            'フォルダがないので作成する
            MkDir GetFolderName & "\" & rsf!出力先フォルダ名
        End If
        
        '次のリストへ移動
        rsf.MoveNext
    Loop
    
    '砂時計を表示
    DoCmd.Hourglass True
    
    'ループでemlファイルを作成
    Do Until rst.EOF
        '何もしないイベント（応答なしを防ぐ為）
        DoEvents

        'プログレス表示
        varReturn = Application.SysCmd(acSysCmdInitMeter, counter & "個目のデータを変換中．．．", reccnt)
        
        '変数を初期化
        tempAttach = ""
        
        '出力先を取得
        exportpath = GetFolderName & "\" & rst!出力先
        
        '添付ファイルを取り出す
        With rst("attach").Value
            While (Not .EOF)
                For Each v In .Fields
                    If (v.Name = "FileName") Then
                        '添付ファイルがあるので、添付ファイルフォルダに取り出し
                        .Fields("FileData").SaveToFile exportpath
                        Exit For
                    Else
                        '添付ファイルなし
                    End If
                Next
                .MoveNext
            Wend
        End With

        '次のレコードへ移動
        rst.MoveNext
        varReturn = Application.SysCmd(acSysCmdUpdateMeter, counter)
    Loop

    '終了処理
    Set db = Nothing
    Set rst = Nothing
    Set rsf = Nothing
    Access.Application.SysCmd (acSysCmdRemoveMeter)
    DoCmd.Hourglass False
    
    MsgBox reccnt & "件のNotesデータから添付ファイルを取り出しました。"
    
End Function

EML形式を連続インポートする

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

'Filesysmtem Object等を宣言
Public FSO As Object
Public WSH As Object
Public OutlookApp As Object
Public fldImport As Object

'一時フォルダの指定
Public tempman As String
Public oLog As Object

'Sleep
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

'EML形式をOutlookにコピーする
Public Function importEml()
    'グローバル設定
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set WSH = CreateObject("WScript.Shell")
    Set OutlookApp = CreateObject("Outlook.Application")
    tempman = CreateObject("WScript.Shell").SpecialFolders.item("Desktop") & "\tempnotes"

    'Outlook側インポートフォルダの指定
    Const olFolderInbox = 6
    Set fldImport = OutlookApp.session.GetDefaultFolder(olFolderInbox)
    Set fldImport = fldImport.Folders("インポート")
    fldImport.Display
    
    'ログの出力用
    Dim fn
    fn = FSO.getParentFolderName(tempman) & "\" & _
         FSO.GetBaseName(tempman) & "_" & _
         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
    
    'EMLインポート開始
    log "START:" & FSO.GetFolder(tempman).Name
    Call LoopFolder(FSO.GetFolder(tempman))
    
    '終了処理
    OutlookApp.ActiveExplorer.Close
    log "インポートは終了しました。"
    oLog.Close
    
    MsgBox "インポート処理終了"
    Set oLog = Nothing

End Function

'サブフォルダまで含めて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)
    '// エラー無視
    log "OPEN EML: " & emlFile.Name

    '// メールが開いていたら閉じる
    While Not OutlookApp.ActiveInspector Is Nothing
        OutlookApp.ActiveInspector.Close
        Sleep 500
    Wend

    '// eml ファイルを Outlook で開くコマンドを実行
    WSH.Run "outlook /eml """ & FSO.getParentFolderName(emlFile) & _
        "\" & emlFile.Name & """"

    '// Outlook 起動待ち
    While OutlookApp.ActiveInspector Is Nothing
        Sleep 500
    Wend
    
    Debug.Print Err.Number

    '// メールフォルダ移動
    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)
End Sub

その他

VBAにてメール以外のNSFテーブルへ接続して読み書きをする手段もあるようなのですが、まだ自分は確立できていません。そこで「読み取り専用」ではありますが、Notes DBのODBC Driverを利用してAccessやExcelで接続しデータを引っこ抜く方法をここに残しておきます。

注意点

利用する為には、いくつかの注意点があります。

1. Notes AdministratorではなくNotes本体がインストールされてる必要性があります。
2. Notes 8.5の場合は、32bit版のODBCドライバである必要があります（64bit版は利用できません）。
3. また、その場合利用するExcelやAccessも32bit版を利用する必要があります（64bit版では接続が出来ません）
4. 日本語名のDBは名前が文字化けしますが利用可能です。

また、例えばOffice2016 VL版はWindowsインストーラでインストールされていますが、Access2016単品版はクイックインストール（C2R）版なので同居が出来ないといった問題があります。Accessを利用する場合はOfficeのProfessional版を使うか？Accessのみでの運用が必要です。

ODBCドライバのインストール

NotesDBにExcelやAccessから接続してデータを抜き取る為のODBCドライバをインストールします。利用するのは32bit版となります。

1. ODBCドライバを入手しておく
2. 解凍してsetup.exeを実行する
3. インストール項目は全部を選択する
4. インストールが完了する
5. インストールそのものは非常に簡単に完了します。
6. 但し、インストール時にNotesの場所が見つからないみたいなエラーが出た場合には、以下の処理を追加します
7. システム環境設定を開く
8. ユーザ環境設定のPathを選択して、編集をクリック
9. 新規追加で、「C:\Program Files (x86)\IBM\Lotus\Notes\」を追加する
10. 再起動してドライバを入れ直す

図：環境変数に値を追加するのが面倒

ODBC接続設定（DSN）を作成する

以下の手順でODBC接続を作成する必要があります。今回はAdminでの接続設定を作成します。

1. コントロールパネルからODBCアドミニストレータ(32bit)を開く
2. システムDSNを開く
3. 追加をクリック
4. Lotus Notes SQL Driverを選択
5. 文字が見切れてるので、Shift+Tabを2回押してから、spaceを押すとフルサイズになって表示される
6. Data Source Nameは適当につける。
7. 下の方のAdd Userをクリックして、adminのIDファイルを指定して追加する
8. パスワードを入力する
9. Domino Serverのプルダウンを開くと「サーバーリスト」が出てくるので選択（パスワードを求められる）
10. Databaseはプルダウンで選択する
11. OKをクリックできるのでクリックするとDSNが作成される

図：管理者権限で接続が必要です。

データを抜き取る

作成したODBCを使って、Excelで抜いてみようと思います。Accessのほうがリンクテーブルでとれるので非常に楽なのでExcelだと使い勝手が悪いですが、IDとPWがわかっていればPower Queryでも接続して取得が可能のようです。但し読み取り専用なので、データの取得しか出来ません。

VIEW, Tableについては抜くことが出来ることを確認しています。以下はExcel2016の例なので最新版だとまた手順が異なる場合があります。

1. Excelを起動する
2. データタブのその他のデータソースをクリック
3. データ接続ウィザードをクリック
4. ODBC DSNをクリックして次へ
5. 作成した名前のDSNが出てくるので選択する
6. データベースとテーブルの選択にて、取り出すテーブルを選択する
7. 貼り付ける場所を指定する
8. データが抜き取られる（テーブル形式で貼り付けがされる）

権限不足やエラーなどで抜けないようなテーブルもあったりしますが、概ねテーブルデータをそのまま引っこ抜けているので、AdministratorのDesignerと合わせれば概ねアプリケーションのGUIとバックエンドを把握することが可能です。個別のドキュメントが何処のテーブルに格納されてるのかがわかれば、個別データも抜けると思います。

図：DB毎にDSN作らなければいけなのが面倒だけど

関連リンク

• グループウェアー（ノーツ）のデータを出力してExcelの表を作成する
• Notesデータベースからkintoneアプリを作る
• Lotus Notes To Excel R5
• ExcelのデータをNotes文書にするVBAのサンプルファイル
• ExcelでLotus Notesのデータを取り出す
• VBAでNotesのタスク一覧を取得する簡単なサンプル
• IBM Lotus Notes データベースにアクセスし、値を取得するサンプル
• Lotus Domino Designer 6.5.1 ヘルプ
• 【LOTUS NOTES】VBScriptでメールを取得
• Notesデータベースのアーカイブの管理
• Notes NSFファイルのデータをcsvファイルに変換してみた！
• NotesメールDBを添付ファイルを含めAccessDBに取り込み
• Excel VBAでオブジェクト指向プログラミング（Notesデータベース編）
• NotesをVBAでコントロールするTips
• OUTLOOKへ emlファイルを一括登録する
• Lotus ノーツデータベースにアクセスする - Excel VBA
• VBAでNotesメールを作成・送信する_最も簡単なサンプル
• VBAでNotesのタスク一覧を取得する簡単なサンプル
• 【VBA】Notesカレンダーを取得する簡単なサンプル【繰り返し予定対応バージョン】
• Lotus Notes から他のユーザーまたはMicrosoft 365に移行Office 365
• Notesのプロが失敗しないNotesメール移行をサポート Exchange Onlineへの移行で運用管理工数を削減
• 企業のNotes離れが加速！移行はどのように進めるべきか
• NotesからOutlook Expressへの移行(メール)
• 【実録】手軽なソフトでノーツメールをOutlook形式に変換
• EMLをGmailにバッチでインポートする方法
• Notes Importer - GAS
• Lotus Notes Send EMail from VB or VBA
• Lotus Notes/Dominoアプリケーションのレガシーデータへのアクセス
• (参考) Notes / Domino 9.0 の IBM ODBCドライバー (旧 NotesSQL) は Notes 10.0.X、Notes 11、Domino 10.0.X、Domino 11 サーバーで動作させる方法
• Packaged ODBC drivers (DataDirect) のダウンロード
• Lotus NotesSQL ODBC Driver 8.0
• 文字化け対応StrConv
• How to Identify the Document is in Inbox/Draft/Sent in Lotus Notes Using Notes API?
• 特殊文字コード（機種依存文字等）置換え。
• Excel VBA でファイル名に使えない文字を取り除く・チェックする
• Notes ODBC Driver Download