VBAでLotus NotesのDB内ビュー全データを引き抜く
以前、NotesのNSFファイルからEML変換してOutlookへ突っ込むプログラムをAccessで作成しました。同様にNotes内のアプリで使ってるデータベース内のビューで表示されてるデータを引っこ抜く必要があった為に、ウェブ上の情報を元に構築してみました。
その内容はメール変換同様にNotesのCOMを使ってDBに接続し、Lotus Scriptで引き抜くコードがそのまま利用できる感じです。今回はExcelで作成し64bitコードで記述してあります。
リンク
目次
今回使用するファイル
- Notes Getter - Microsoft Excel
今回はDBと繋がってるビューのデータを引き抜いています。処理はリボンにメニューを作って使いやすく仕立ててあります。
※2023年8月23日、リッチテキストフィールドのデータ、添付ファイル、Wordへの変換ができるようになりました。
事前準備
サーバー・DB情報を用意する
このアプリを使う為に必要なNotesサーバの情報とデータを引っこ抜く対象のDBファイル名が必要です。
- Dominoxxxx/hogeというドミノサーバの名前が必要になります。
- hogehoge.nsfというファイル名が必要です。データを引き抜きたいアプリ等に連結されてるハズです（Notes Administratorなどでは簡単に見つかります）
これらの情報を次項のセットアップで入力する必要があります。
※nsfについて、リッチテキストフィールドの引き抜きはdbディレクトリ以下に対象のnsfファイルがいることが前提になります。（前述の場合はnsfも他のディレクトリにいる場合には例えば、db\hoge.nsfといった指定が必要です。）
セットアップ
ダウンロードしたExcelを開き、以下の手順でサーバー名とDB名を登録します。
-
リボンにNotesというタブがあるので開く
-
設定をクリックする
-
設定ダイアログが出るので、サーバー名とDB名を指定して保存をクリック
Excelファイルと同じ場所にsetting.iniというファイルに設定が書き込まれます。
図：独自のリボンをつけてあります
図：ダイアログにサーバ名とDBファイル名を入れる
アプリの仕様
NotesのDBには様々なビューが含まれていますが、ユーザが作成したものでは無い管理用のビューなども含まれています。このアプリでは（）から始まる管理用のビューについては処理をスルーするようにしています。
また、ビューの名前でシートを生成するようにしていますが、￥マークについてはシート名に使えないのでアンダーバーで代替しています。また、一度取得したのち再度実行すると、シートが既に作成済みということでエラーとなるので、作成されたシートを全削除してから利用する必要があります。
使い方とソースコード
使い方
利用方法は簡単です。前述の設定が完了していれば、「データ取得」ボタンを実行するだけです。ビューの数だけシートが生成されて、ビューの中のデータを引き抜きます。タイトル行などは自動で取得してセットされます。よって、サーバとDBだけ変更すれば汎用的にデータを引き抜くことが可能です。
処理中は左下のステータスバーに進捗率が表示されるようになっています。Notes接続時にはパスワード入力欄が出てきますので、パスワードを入れるとデータ取得開始です。
※VBA警告が出ている場合実行許可をしてあげる必要があります。
図：ログインダイアログが出てくる
コードと解説
参照設定
遅延バインディングだと、コード補完が効かないので、今回は参照設定から「Lotus Domino Objects」を追加しています。これがないと、コードが動きませんので当然ですが、利用するPCではNotesクライアントがインストールされている必要性があります。
図：今回のコードは参照設定を加えています
データを取得するメイン関数
データエクスポートを管理するメインで実行される関数です。後述の関数を随所で呼び出して全体を制御しています。
|
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 |
'Notes Session Initialize（Generalプロシージャ） Public session As New NotesSession Public db As NotesDatabase Public viewname As Variant '指定DB内の全ビューデータを出力する Public Function getAllViewData() On Error GoTo kinoko '問い合わせダイアログ Dim rc As Integer rc = MsgBox("Notesビューデータを引き抜きますか？？", vbYesNo + vbQuestion, "確認") If rc = vbYes Then '処理を続行する Else MsgBox "処理をキャンセルしました" Exit Function End If 'ini設定を取得する Dim servername As String Dim dbname As String servername = IniRead("USER", "servername", "") dbname = IniRead("USER", "dbname", "") '設定チェック If servername = "" Or IsNull(servername) Then MsgBox "サーバー設定がありません" Exit Function End If If dbname = "" Or IsNull(dbname) Then MsgBox "DBが指定されていません。" Exit Function End If 'セッション初期化 Set session = New NotesSession Call session.Initialize 'DB接続 Set db = session.GetDatabase(servername, dbname) 'カーソルを砂時計にする Application.Cursor = xlWait 'ビュー一覧を取得する Dim viewlist As Variant viewlist = NotesViewList() 'ビューリストの配列の要素の数を取得する Dim viewcount As Integer Dim i As Integer Dim ret As Boolean viewcount = UBound(viewlist) 'ビューの名称を取得しつつ、データを引き抜く For i = 1 To viewcount Debug.Print viewlist(i) 'ビューの名称を取得する viewname = viewlist(i) 'ビュー名を元にデータを引き抜く ret = getNotesViewData() Debug.Print ret Next 'カーソルを戻す Application.Cursor = xlDefault '終了メッセージ MsgBox "データ取得が完了しました。" 'オブジェクトを開放する Set session = Nothing Set db = Nothing Exit Function kinoko: 'カーソルを戻す Application.Cursor = xlDefault 'オブジェクトを開放する Set session = Nothing Set db = Nothing MsgBox "エラー番号:" & Err.Number & vbCrLf & _ "エラーの種類:" & Err.Description, vbExclamation End Function |
- 後述のメソッドでも利用する各種グローバル変数をGeneralプロシージャの中で宣言しておきます。
- メール移行のプログラムと違い、Lotus.NotesSessionで動かしてるのでCall session.initializeが必要です。また、Call session.initialize(password)とすると自動でログインするようになります。
- setting.iniからサーバ名とDBファイル名を取得してGetDatabaseで接続しています。
- NotesViewList関数を実行して、DB内のビューの一覧を配列で取得しています。
- ループで配列を回し、ビューの名称を取得したらgetNotesViewData関数でシート作成とデータ引き抜きを行っています。
- 最後にsessionとdbのオブジェクトを開放しています（でないとnotesプロセスが残る可能性がある）
ビューの一覧を取得して配列で返す
前述のメイン関数から呼び出されて、指定のDB内にあるビューの一覧を取得して配列で返す関数です。但し、管理用ビューについては処理をスルーするようにフィルタしています。
|
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 |
'ビュー一覧を取得する(配列で返す) Public Function NotesViewList() As Variant On Error GoTo tomato 'DB接続してビューを取得する Dim view As Variant 'View一覧用の配列 Dim viewlist() As Variant Dim cnt As Integer cnt = 1 'View一覧を取得する view = db.views For i = LBound(view) To UBound(view) 'Viewの名前を取得する viewnameman = view(i).Name 'Viewに特有の文字が含まれているかどうか If InStr(viewnameman, "$") > 0 Then '含まれている場合はスルーする Else If Left(viewnameman, 1) = "(" Then '含まれている場合はスルーする Else 'Viewnameが空の場合はスルーする If IsNull(viewnameman) Or viewnameman = "" Then '処理をスルーする Else '無い場合は処理対象とする '要素の数を変更する ReDim Preserve viewlist(cnt) '配列に加える viewlist(cnt) = viewnameman 'カウンタを回す cnt = cnt + 1 End If End If End If Next i '配列を出力する NotesViewList = viewlist Exit Function tomato: MsgBox "エラー番号:" & Err.Number & vbCrLf & _ "エラーの種類:" & Err.Description, vbExclamation End Function |
- 動的配列とするため、Redim Preserveで逐一配列を拡張しながらビューの名称を１次元配列で追加しています。
- 配列で返すために関数の戻り値の型はVariantとしています。
対象DBからデータを引き抜いて書き出す
ビューの名称を元にシートを新規追加し、そこにタイトル行とビューの実際のデータを書き出す関数です。
|
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 |
'指定のビューのデータをカレントシートに書き出す Public Function getNotesViewData() As Boolean 'DBとViewの宣言 Dim view As NotesView Dim collection As NotesViewEntryCollection Dim entry As NotesViewEntry Dim column As NotesViewColumn 'ワークシート Dim xlsheet As Worksheet 'Viewの指定 Dim rows As Long, cols As Long, i As Long Dim maxrows As Long, maxcols As Long Dim v As Variant Set view = db.GetView(viewname) rows = 1 maxcols = view.ColumnCount ' 最大列 '行数を取得する Set collection = view.AllEntries maxrows = collection.count 'レコード数が0かどうかのチェック If maxrows = 0 Then '行データが無いので何もせずに処理を終わる getNotesViewData = False Else 'ビューの名称からオカシナ文字はreplaceする sheetname = Replace(viewname, "\", "_") sheetname = Replace(sheetname, "/", "_") '新規に作成したシートをアクティブにする Sheets.Add(After:=Sheets(Sheets.count)).Name = sheetname Sheets(sheetname).Select 'シートを取得する Set xlsheet = Worksheets(sheetname) ' 列見出しの作成 xlsheet.rows(1).NumberFormat = "@" ' 文字列書式 For cols = 1 To maxcols Set column = view.Columns(cols - 1) xlsheet.Cells(rows, cols).Value = column.Title Next '次の行を指定 rows = rows + 1 'ビューデータの出力 For i = 1 To collection.count 'フリーズ防止 DoEvents 'エントリーを取得する Set entry = collection.GetNthEntry(i) For cols = 1 To UBound(entry.ColumnValues) + 1 v = entry.ColumnValues(cols - 1) If InStr(TypeName(v), "STRING") = 1 Then ' STRING or STRING( ) xlsheet.Cells(rows, cols).NumberFormat = "@" ' 文字列書式 End If xlsheet.Cells(rows, cols).Value = v 'ステータスバーに進捗率を表示 Application.StatusBar = i & "/" & maxrows & " (" & Format(i / maxrows, "0%") & ")" Next rows = rows + 1 Next 'ステータスバーのクリア Application.StatusBar = False '完了 getNotesViewData = True End If End Function |
- データが無いビューの場合は処理をスルーしています
- ビュー名に於いてシート名に使えない文字はアンダーバーにreplaceさせています。
- 列見出しを作成した後、２行目以降からentry.ColumnValuesにて列のデータを書き出しています。
- ステータスバーに進捗率の値を表示させています。
- 最後に処理が終わったらメイン関数に戻し、次のビューの処理を行っていきます。
リッチテキストフィールドの引き抜き
いわゆるNotes文書と呼ばれるリッチテキストな内容で、添付ファイルなどが付いてるような１つ１つのページのデータで、テキストデータだけをrichtextシートに一気に書き出します。本体自体はRTF形式でのエクスポートも出来るのですがメソッドは存在しないようで、後述のWord変換を利用して取得可能です。。
リボンのリッチテキスト取得を実行すると抜き出しが出来ます。
|
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 |
'リッチテキストフィールドの値を調べてドキュメントを取得する Public Function getRichDocument() '問い合わせダイアログ Dim rc As Integer rc = MsgBox("Notesのリッチテキストデータを引き抜きますか？？", vbYesNo + vbQuestion, "確認") If rc = vbYes Then '処理を続行する 'カーソルを砂時計にする Application.Cursor = xlWait Else MsgBox "処理をキャンセルしました" Exit Function End If On Error Resume Next Dim dc As NotesDocumentCollection Dim doc As NotesDocument Dim tempdoc As Variant Dim temobody As Variant Dim doctitle As String Dim dateman As String Dim lastmodified As String Dim universalid As Variant Dim doccount As Integer 'ワークシート Dim xlsheet As Worksheet 'シートを取得する Set xlsheet = Worksheets("richtext") 'カウンタ Dim cnt As Integer Dim reccnt As Integer cnt = 2 reccnt = 1 'ini設定を取得する Dim servername As String Dim dbname As String servername = IniRead("USER", "servername", "") dbname = IniRead("USER", "dbname", "") 'セッション初期化 Set session = New NotesSession Call session.Initialize 'DB接続(dbディレクトリ以下に対象のファイルが入ってるとする) Set db = session.GetDatabase(servername, "db\" & dbname) '--データベースの全てのNotes文書を取得 Set dc = db.AllDocuments doccount = dc.count '--Notes文書を順次に取得 Set doc = dc.GetFirstDocument Do Until doc Is Nothing 'フリーズ防止用 DoEvents 'temobodyを初期化 temobody = "" 'ドキュメントのIDを取得する universalid = doc.universalid 'ドキュメントタイトルを取得する tempdoc = doc.GetFirstItem("Subject").Values doctitle = tempdoc(0) '文書投稿日付を取得する dateman = doc.GetFirstItem("PostedDate").Text '最終更新日を取得する lastmodified = doc.lastmodified 'カテゴリを引き抜く category = doc.GetFirstItem("Categories").Text 'ドキュメント本文を取得する For Each Item In doc.items 'フィールドがリッチテキストであれば取得する If (Item.Type = RICHTEXT) Then 'テキスト本文を取得する tempbody = doc.GetFirstItem("Body").Text End If Next 'temobodyが空かどうか？ If tempbody = "" Then '空なのでなにもせずにそのままスルーする Else 'シートに書き出す With xlsheet .Cells(cnt, 1) = universalid .Cells(cnt, 2) = doctitle .Cells(cnt, 3) = dateman .Cells(cnt, 4) = lastmodified .Cells(cnt, 5) = category .Cells(cnt, 6) = tempbody End With 'カウンタを加算する cnt = cnt + 1 End If 'ステータスバーに進捗率を表示 Application.StatusBar = reccnt & "/" & doccount & " (" & Format(reccnt / doccount, "0%") & ")" 'レコードカウントを加算する reccnt = reccnt + 1 '次のドキュメント Set doc = dc.GetNextDocument(doc) Loop '終了メッセージ MsgBox "リッチテキストデータの引き抜きが完了しました。" '終了処理 'カーソルを戻す Application.Cursor = xlDefault 'ステータスバーのクリア Application.StatusBar = False 'オブジェクトを開放する Set session = Nothing Set db = Nothing Set xlsheet = Nothing End Function |
- db以下に対象のnsfファイルがいることが前提です。
- 引き抜いたデータはテキスト形式で、richtextシートにID, タイトル, カテゴリ, 投稿日, 最終更新日, 本文で書き出します。
- 文書内の添付ファイルの取り出しは未実装です。
リッチテキストの添付ファイルを取り出す
前述のリッチテキストフィールドのデータには、ExcelやWordといった添付ファイルが付いてる場合があります。これらはバイナリデータであるため、前述のテキスト抜き出しでは取得されることがありません。それでは困るので、1ドキュメントのテキストを抜いた後にこのバイナリデータを取り出すコードを追加し、attachmentシートにuniversalidを元にデータを書き出しするコードを追加します。
あとはPowerQuery等を利用すればrichtextシートとuidを基準に連結する事が可能です。以下は前述の「ドキュメント本文を取得する」に追記するコードになります。
|
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 |
//Generalプロシージャに追記 '添付ファイルタイプ Const EMBED_ATTACHMENT = 1454 //以下は冒頭に追記する変数等 '変数を宣言 Dim buf As Variant, attaches As Variant, attach As Object Dim attachtype As Variant 'シートを取得する Dim attachsheet As Worksheet Set attachsheet = Worksheets("attachment") 'カウンタ Dim acount As Integer acount = 2 'カレントディレクトリにtempフォルダの作成 Dim tempman As String tempman = "temp" destDrive = ThisWorkbook.Path & "\" & tempman & "\" If Dir(destDrive, vbDirectory) = "" Then MkDir destDrive End If 'Bodyを取得しておく buf = doc.GetFirstItem("Body") //以下はドキュメント本文を取得するコードに追記する For Each Item In doc.items 'フィールドがリッチテキストであれば取得する If (Item.Type = RICHTEXT) Then 'テキスト本文を取得する tempbody = doc.GetFirstItem("Body").Text '添付ファイルの有無確認 If doc.HasEmbedded Then attaches = Empty attaches = Item.EmbeddedObjects '添付ファイルを取り出し For Each atfile In attaches If atfile.Type = EMBED_ATTACHMENT Then If atfile.Name = "" Or IsNull(atfile.Name) Then 'ファイル名がないからスルーする Else atfile.ExtractFile destDrive & atfile.Name 'attachmentシートに書き出す With attachsheet .Cells(acount, 1) = universalid .Cells(acount, 2) = atfile.Name .Cells(acount, 3) = destDrive & atfile.Name End With 'カウンタを加算する acount = acount + 1 End If End If Next End If End If Next |
- このVBAファイルがある場所にtempというディレクトリを作って添付ファイルの解凍先として指定してる（destDrive）
- GetFirstItemにてBodyを取得した後に、EmbeddedObjectsにて添付ファイルの配列を取得する事が可能です
- doc.HasEmbeddedにて添付ファイルがあるかどうかを判定可能です。但し、jpgなどの画像ファイルは添付ファイルとみなされないので取得できません。
- atfile.typeが1454（EMBEDDED_ATTACHMENT）だったら添付ファイルなので処理を続行する
- ファイル名が無いものは処理をスルーする
- 添付ファイルはループで回してExtractFileにて取り出すことが可能。この時、atfile.Nameでファイル名も取得しておいて、カレントディレクトリ内のtempフォルダ内にファイルを生成する
- 最後にシートにuniversalid、ファイル名、フルパスを記述して完了
Notesのリッチテキストフィールドに添付されてるファイルはとてつもなく古いファイルも残ってる可能性があります。それは古いコンピュータウイルスが潜んでいる可能性もあるため、一部のファイルはウイルスチェッカーに引っかかり動作が阻害されExcelが落ちる場合もありますので要注意。
リッチテキストをWordファイルに変換して出力
Lotus NotesのScriptにはFileExportというものでボタンに割り当てて使うコマンドにてリッチテキストをRTF形式で保存する機能があります。しかし、VBAから叩く場合のメソッドにRTFとして保存する為のものがなく、また前述の方式では添付ファイルとして画像の取り出しも出来ません。
そこで、Lotus NotesのUI自体を操縦して、リッチテキストをクリップボード経由でWordファイルにコピペし連続保存する方式が確立できました。前述までのNotessessionとして行う方法ではなく、Notes自体を起動して行いますので、ファイル生成中はPCは弄ってはいけません（またクリップボードを何度も書き換えていますので、別の作業でコピペをすると阻害したり、別のものが貼り付けられたりするので要注意）。
初回実行時のみ、確認のダイアログが出るので、「今回のLotus Notesセッションでこのアクションを実行するために署名者を信用する」にチェックを入れてOKをクリックする必要があります。
※文書タイトルにファイル名につけられない環境依存文字がある場合、名前を付けて保存ダイアログが出てしまうことがあるので、その場合はそのまま前述のtempディレクトリを指定してＯＫをクリックすれば処理が継続されます。コード内だと「fncSheetNameModify関数」に対象の文字を追加することで、これらは空文字に置き換わるので、追加していくとスムーズに処理が行われると思います。
※またNotesが起動していて何かの文書を開いてる状態の場合は必ず全部閉じてから実行が必要です。
図：初回起動だけチェックが必要
|
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 |
'リッチテキストをWordに変換して取り込み Public Function getRichWord() '問い合わせダイアログ Dim rc As Integer rc = MsgBox("NotesのリッチテキストデータをWordに変換して引き抜きますか？？", vbYesNo + vbQuestion, "確認") If rc = vbYes Then '処理を続行する 'カーソルを砂時計にする 'Application.Cursor = xlWait Else MsgBox "処理をキャンセルしました" Exit Function End If On Error Resume Next '各種変数の宣言 Dim ws As Object Dim uidoc As Object Dim session2 As Object Dim db2 As Object, doc2 As Object Dim dc As Object Dim wordfile As String Dim wordpath As String Dim destDrive As String Dim universalid As Variant Dim doccount As Integer Dim buf As Variant Dim worddoc As Object Dim mainStory As Variant 'ワークシート Dim xlsheet As Worksheet 'シートを取得する Set xlsheet = Worksheets("wordfile") 'Word関連 Dim wordObj As Object Set wordObj = CreateObject("Word.Application") 'カウンタ Dim cnt As Integer Dim reccnt As Integer cnt = 2 reccnt = 1 'カレントディレクトリにtempフォルダの作成 Dim tempman As String tempman = "temp" destDrive = ThisWorkbook.Path & "\" & tempman & "\" If Dir(destDrive, vbDirectory) = "" Then MkDir destDrive End If '別のプログラムでOLEの操作が完了するまで待機をつづけますの対策 Application.DisplayAlerts = False 'ini設定を取得する Dim servername As String Dim dbname As String servername = IniRead("USER", "servername", "") dbname = IniRead("USER", "dbname", "") 'DB接続(dbディレクトリ以下に対象のファイルが入ってるとする) Set session2 = CreateObject("Notes.NotesSession") Set db2 = session2.GetDatabase(servername, "db\" & dbname) Set ws = CreateObject("Notes.NotesUIWorkspace") Set dc = db2.AllDocuments doccount = dc.count '--Notes文書を順次に取得 Set doc2 = dc.GetFirstDocument Call ws.OpenDatabase(servername, "db\" & dbname) 'ループでドキュメントを順次処理 Do Until doc2 Is Nothing 'フリーズ防止用 DoEvents 'word関連初期化 wordfile = "" wordpath = "" tempdoc = "" 'ドキュメントのIDを取得する universalid = doc2.universalid 'universalidが無いものはスルーする If universalid = "" Or IsNull(universalid) Then '処理をスルーする Else 'ドキュメントタイトルを取得する tempdoc = doc2.GetFirstItem("Subject").Values wordfile = tempdoc(0) 'タイトルから環境依存文字を除外 wordfile = fncSheetNameModify(wordfile) '同名ファイル防止のために、wordfileにカウンタを付ける wordfile = wordfile & "_" & cnt '編集モードで文書を開く Set uidoc = ws.EDITDOCUMENT(True, doc2, False) 'Body要素をクリップボードにコピー Call uidoc.GOTOFIELD("Body") Call uidoc.SelectAll Call uidoc.Copy Call uidoc.Close(True) 'Wordを起動して新規ドキュメントを作成 wordObj.Visible = True Set worddoc = wordObj.DOCUMENTS.Add 'A3サイズに指定 worddoc.PageSetup.PaperSize = wdPaperA3 'Wordにコピペ Set mainStory = worddoc.StoryRanges(1) mainStory.Paste '保存先ファイル名 wordpath = destDrive & wordfile & ".docx" 'Wordを保存して閉じる worddoc.SaveAs2 wordpath worddoc.Close 'シートに書き出す With xlsheet .Cells(cnt, 1) = universalid .Cells(cnt, 2) = wordfile .Cells(cnt, 3) = wordpath End With 'オブジェクトを開放する Set uidoc = Nothing Set worddoc = Nothing End If 'ステータスバーに進捗率を表示 Application.StatusBar = reccnt & "/" & doccount & " (" & Format(reccnt / doccount, "0%") & ")" 'レコードカウントを加算する reccnt = reccnt + 1 'カウンタを加算する cnt = cnt + 1 '次のドキュメント Set doc2 = dc.GetNextDocument(doc2) Loop 'Wordをクローズする wordObj.Application.Quit '終了メッセージ MsgBox "リッチテキストデータの引き抜きが完了しました。" '終了処理 'カーソルを戻す Application.Cursor = xlDefault 'ステータスバーのクリア Application.StatusBar = False 'displayalertを元に戻す Application.DisplayAlerts = True 'オブジェクトを開放する Set session2 = Nothing Set db2 = Nothing Set xlsheet = Nothing Set wordObj = Nothing Set doc2 = Nothing Set ws = Nothing End Function '文字列から利用できない文字を空文字に置き換えるメイン関数 Public Function fncSheetNameModify(buf As String) As String fncSheetNameModify = fncDeleteStrings$(buf, "'", "’", "＇", "*", ":", "?", "\", "￥", "＊", "／", "：", "？", "[", "［", "］", "]", "＼", "/", "<", ">", "#", "%", "(", ")", "》", "《", " ", " ", """", "|") fncSheetNameModify = Left$(fncSheetNameModify, 31) 'シート名は31文字まで End Function '環境依存文字を置き換える関数 Public Function fncDeleteStrings(buf As String, ParamArray arrDeleteStr()) As String Dim var As Variant fncDeleteStrings = buf For Each var In arrDeleteStr '配列に指定された文字を削除していく fncDeleteStrings = Replace(fncDeleteStrings, var, "") Next var End Function |
- Notes自体を操縦する場合には「NotesUIWorkspaceクラス」を使うのですが、遅延バインディングでなければ使えないので注意
- universalidが無いものは処理をスルーするようにしています。
- 用紙サイズは、wdPaperA3をもってA3サイズを指定してる（A4だと文書の内容によっては、はみ出す場合があるため）
- 操縦中に「別のプログラムでOLEの操作が完了するまで待機をつづけます」というメッセージが出る場合があるので、これを封じるために「Application.DisplayAlerts = False」を加えています。
- 同名タイトルの文書対策として、ファイルのタイトルを取得したらカウンタの値をつなげてファイル名としています。
- Body部分をコピーするには編集モードをTrueにする必要があるので、「ws.EDITDOCUMENT(True, doc2, False)」として有効化しuidocとして取得しています。
- uidocにてBodyに移動=>全部選択=>コピーしてドキュメントを自動で閉じるようにしています。
- WordオブジェクトにDocument.addにて新しい文書を追加してコピペ、保存、文書を閉じるを繰り返し作業で行っています。
- Wordファイルは添付ファイルと同様に、Bookのあるディレクトリ以下のtempディレクトリ内に自動で保存されていき、スプレッドシートのwordfileシートに情報が記述されていきます。
- fncDeleteStrings関数でSubjectの環境依存文字を除外してファイル名として返します。
- Notesリンクオブジェクトや、添付ファイルオブジェクトは処理をスルーします。添付ファイルが欲しい場合は前述の機能をご利用ください。
動作はそこまで早くは無いですが、放置しておけば全ドキュメントを回して逐一Word化していきますので、画像も取得可能です。画像の幅があっていないものもありますが、これでほぼNotesのドキュメント類をエクスポートする事が可能です。
関連リンク
-
When calling Notes from Excel/VBA do I need to explicitly close the session?
- No.25 EXCEL連携(3) ～ ビューをEXCELに書き出す（高速バージョン）
-
Automate downloading Lotus Notes Attachment to folder on daily basis
- VBA - grabbing column names from lotus notes database using getColumnNames method
- 【PowerShell】Notes 文書を CSV ファイルにエクスポートする
- Examples: CurrentDatabase property (NotesSession - LotusScript)
- Examples: GetDatabase method
- Lotus ノーツデータベースにアクセスする
- Notesデータベースのアーカイブの管理
- 例:アイテムとその値を取得する
- Lotus Notes Database - Get text from field which includes attachment
- Lotus Script における GetItemValue と FieldGetText| ノーツドミノ
- Simple export from Notes view to Excel
- グループウェアー（ノーツ）のデータを出力してExcelの表を作成する
- Notes文書の添付ファイルを取得するLotusScript
- RTF 形式での Notes ドキュメントとリッチ テキスト フィールドのエクスポート
- Convert Notes Documents and Rich Text Fields to HTML
- How to export Rich Text fields as HTML from Notes with LotusScript?
- 【ExcelVBA入門】カレントディレクトリの取得・変更方法を徹底解説！
- Excel VBAでフォルダを作成する：MkDir
- LotusScript Gold Collection
- How do I write @Command([FileExport] in Lotus Script?
- Export Lotus Notes documents to Microsoft Word
- FileExport @Command (Formula Language)
- COPY TEXT FROM NOTES RTF INTO MS WORD FILE
- Exporting Notes Document data into a Microsoft Word document
- Paste content from clipboard into rtfield inside a new section
-
Automate downloading Lotus Notes Attachment to folder on daily basis
-
Examples: GetMIMEEntity method (NotesDocument - LotusScript®)
-
LotusScript を使用して Notes からリッチテキストフィールドを HTML としてエクスポートするにはどうすればよいですか?
- Excel VBAにて「別のプログラムでOLEの操作が完了するまで待機をつづけます」の表示がでて処理がとまる
- VBAでWordを開く,名前をつけて保存する,閉じる｜非表示や読み取り専用で開く方法も紹介
- 【ExcelVBA入門】DisplayAlertsプロパティでメッセージを制御する方法とは
