2023年8月8日 / 最終更新日時 : 2023年8月29日 officeの杜 msoffice

VBAでLotus NotesのDB内ビュー全データを引き抜く

以前、NotesのNSFファイルからEML変換してOutlookへ突っ込むプログラムをAccessで作成しました。同様にNotes内のアプリで使ってるデータベース内のビューで表示されてるデータを引っこ抜く必要があった為に、ウェブ上の情報を元に構築してみました。

その内容はメール変換同様にNotesのCOMを使ってDBに接続し、Lotus Scriptで引き抜くコードがそのまま利用できる感じです。今回はExcelで作成し64bitコードで記述してあります。

Lotus NotesのメールをOutlookに変換して移行する

1 今回使用するファイル
2 事前準備
3 使い方とソースコード
- 3.1 使い方
- 3.2 コードと解説
4 関連リンク

今回使用するファイル

Notes Getter - Microsoft Excel

今回はDBと繋がってるビューのデータを引き抜いています。処理はリボンにメニューを作って使いやすく仕立ててあります。

※2023年8月23日、リッチテキストフィールドのデータ、添付ファイル、Wordへの変換ができるようになりました。

ExcelとAccessに独自のリボンを追加する

事前準備

サーバー・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クライアントがインストールされている必要性があります。

図：今回のコードは参照設定を加えています

データを取得するメイン関数

データエクスポートを管理するメインで実行される関数です。後述の関数を随所で呼び出して全体を制御しています。

'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

'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

'カーソルを戻す

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内にあるビューの一覧を取得して配列で返す関数です。但し、管理用ビューについては処理をスルーするようにフィルタしています。

'ビュー一覧を取得する(配列で返す)
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

'ビュー一覧を取得する(配列で返す)

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

Next i

'配列を出力する

NotesViewList = viewlist

Exit Function

tomato:

MsgBox "エラー番号:" & Err.Number & vbCrLf & _

"エラーの種類:" & Err.Description, vbExclamation

End Function

動的配列とするため、Redim Preserveで逐一配列を拡張しながらビューの名称を１次元配列で追加しています。
配列で返すために関数の戻り値の型はVariantとしています。

対象DBからデータを引き抜いて書き出す

ビューの名称を元にシートを新規追加し、そこにタイトル行とビューの実際のデータを書き出す関数です。

'指定のビューのデータをカレントシートに書き出す
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

'指定のビューのデータをカレントシートに書き出す

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

'次の行を指定

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%") & ")"

rows = rows + 1

'ステータスバーのクリア

Application.StatusBar = False

'完了

getNotesViewData = True

End If

End Function

データが無いビューの場合は処理をスルーしています
ビュー名に於いてシート名に使えない文字はアンダーバーにreplaceさせています。
列見出しを作成した後、２行目以降からentry.ColumnValuesにて列のデータを書き出しています。
ステータスバーに進捗率の値を表示させています。
最後に処理が終わったらメイン関数に戻し、次のビューの処理を行っていきます。

リッチテキストフィールドの引き抜き

いわゆるNotes文書と呼ばれるリッチテキストな内容で、添付ファイルなどが付いてるような１つ１つのページのデータで、テキストデータだけをrichtextシートに一気に書き出します。本体自体はRTF形式でのエクスポートも出来るのですがメソッドは存在しないようで、後述のWord変換を利用して取得可能です。。

リボンのリッチテキスト取得を実行すると抜き出しが出来ます。

'リッチテキストフィールドの値を調べてドキュメントを取得する
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

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

'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を基準に連結する事が可能です。以下は前述の「ドキュメント本文を取得する」に追記するコードになります。

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

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

この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が起動していて何かの文書を開いてる状態の場合は必ず全部閉じてから実行が必要です。

図：初回起動だけチェックが必要

'リッチテキストを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, "'", "’", "＇", "*", ":", "?", "\", "￥", "＊", "／", "：", "？", "&#91;", "［", "］", "]", "＼", "/", "<", ">", "#", "%", "(", ")", "》", "《", " ", "　", """", "|")
    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

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のドキュメント類をエクスポートする事が可能です。

VBAでLotus NotesのDB内ビュー全データを引き抜く

今回使用するファイル

事前準備

サーバー・DB情報を用意する

セットアップ

アプリの仕様

使い方とソースコード

使い方

コードと解説

参照設定

データを取得するメイン関数

ビューの一覧を取得して配列で返す

対象DBからデータを引き抜いて書き出す

リッチテキストフィールドの引き抜き

リッチテキストの添付ファイルを取り出す

リッチテキストをWordファイルに変換して出力

関連リンク

コメントを残すコメントをキャンセル

macOSのWhiskyでWindowsアプリを動かす

携帯ゲーム機ROG Allyを徹底的に検証してみた

今回使用するファイル

事前準備

サーバー・DB情報を用意する

セットアップ

アプリの仕様

使い方とソースコード

使い方

コードと解説

参照設定

データを取得するメイン関数

ビューの一覧を取得して配列で返す

対象DBからデータを引き抜いて書き出す

リッチテキストフィールドの引き抜き

リッチテキストの添付ファイルを取り出す

リッチテキストをWordファイルに変換して出力

関連リンク

コメントを残す コメントをキャンセル

macOSのWhiskyでWindowsアプリを動かす

携帯ゲーム機ROG Allyを徹底的に検証してみた

コメントを残すコメントをキャンセル