Lotus NotesのメールをOutlookに変換して移行する ★🌴 🌴 officeの杜 🥥

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

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

図：起動してみた様子

リンク

今回作成したツール

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

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

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

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

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 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 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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

'添付ファイルだけを取り出すルーチン

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

.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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

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

'フォルダがあれば再帰

For Each objSubFolder In objFolder.SubFolders

LoopFolder objSubFolder

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で接続しデータを引っこ抜く方法をここに残しておきます。

注意点

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

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

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

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

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

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

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

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

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

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

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

データを抜き取る

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

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

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

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

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