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作らなければいけなのが面倒だけど

関連リンク