2018年、IBMの長きに渡って提供されてきたNotesがインドの企業に売却されて、事実上の終焉を迎えました。もとより、現代ではGoogle WorkspaceやMicrosoft365といったモダンな企業向けソリューションがある時代に於いて、Notesはあまりにも古い。また、レガシー資産が多数ある事で、移行できずにズルズルと引きずってしまう大企業もありました。
しかし、クローズドなNotesの開発ノウハウはすでに現代的なものではないので、ウェブアプリケーション等に移行し、メール等も国際標準のものへ移行すべきということで、過去にウェブ上の資料を元に作成し改良を加えた「NotesメールをOutlookに移行させるツール」の情報をまとめて置こうと思います。
図：起動してみた様子
目次
今回作成したツール
- Notes to Outlook v4 - Microsoft Access 64bitで作成しています。
Access VBAにて作成しています。関連リンクにある様々な先人の方々のコードが残されており、これらを元に修正を加えて形にしています。利用する為には、使用するPCにNotesクライアントがインストールされていて、起動させておく必要があります。
Access 2016で動作確認していますので、持っていない人はAccess 2016 Runtimeをインストールしておくと動作させることが可能です。また、今回はOutlookをターゲットにしていますが、以下のエントリーを参考にGmailへインポートも可能です
作成した理由
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からデータ取り込み
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に変換したものも含まれます。主要なコード部分だけを掲載しています。
受信トレイ以外のフォルダ構成を取得する
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
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からテーブルに取り込む
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 |
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 '同じファイルが添付されるのを防ぐ為の変数 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) = "MEC" 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) = "MEC" 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) = "MEC" 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) = "MEC" 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ファイルを生成する
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
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 |
添付ファイルだけを取り出す
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 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形式を連続インポートする
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 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 |
関連リンク
- グループウェアー（ノーツ）のデータを出力してExcelの表を作成する
- Lotus Notes To Excel R5
- ExcelのデータをNotes文書にするVBAのサンプルファイル
- ExcelでLotus Notesのデータを取り出す
- VBAでNotesのタスク一覧を取得する簡単なサンプル
- IBM Lotus Notes データベースにアクセスし、値を取得するサンプル
- Lotus Domino Designer 6.5.1 ヘルプ
- 【LOTUS NOTES】VBScriptでメールを取得
- Notesデータベースのアーカイブの管理
- Notes NSFファイルのデータをcsvファイルに変換してみた！
- NotesメールDBを添付ファイルを含めAccessDBに取り込み
- Excel VBAでオブジェクト指向プログラミング（Notesデータベース編）
- NotesをVBAでコントロールするTips
- OUTLOOKへ emlファイルを一括登録する
- Lotus ノーツデータベースにアクセスする - Excel VBA
- VBAでNotesメールを作成・送信する_最も簡単なサンプル
- VBAでNotesのタスク一覧を取得する簡単なサンプル
- 【VBA】Notesカレンダーを取得する簡単なサンプル【繰り返し予定対応バージョン】
- Lotus Notes から他のユーザーまたはMicrosoft 365に移行Office 365
- Notesのプロが失敗しないNotesメール移行をサポート Exchange Onlineへの移行で運用管理工数を削減
- 企業のNotes離れが加速！移行はどのように進めるべきか
- NotesからOutlook Expressへの移行(メール)
- 【実録】手軽なソフトでノーツメールをOutlook形式に変換
- EMLをGmailにバッチでインポートする方法
- Notes Importer - GAS
- Lotus Notes Send EMail from VB or VBA
- Lotus Notes/Dominoアプリケーションのレガシーデータへのアクセス
- (参考) Notes / Domino 9.0 の IBM ODBCドライバー (旧 NotesSQL) は Notes 10.0.X、Notes 11、Domino 10.0.X、Domino 11 サーバーで動作させる方法
- Packaged ODBC drivers (DataDirect) のダウンロード
- Lotus NotesSQL ODBC Driver 8.0
- 文字化け対応StrConv
- How to Identify the Document is in Inbox/Draft/Sent in Lotus Notes Using Notes API?
- 特殊文字コード（機種依存文字等）置換え。
- Excel VBA でファイル名に使えない文字を取り除く・チェックする