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

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