- ホーム
- Other
- archivemanage
Notesデータベースのアーカイブの管理
添付ファイルをすべてDocumentに貼り付けるタイプのNotesDataBaseを使用しているため、2年くらいで1Gバイトを超えて重く、不安定になるため、
定期的に1年分をアーカイブしている。この文書のリストをAccessで管理しているが、従来はNotesのViewから、表形式でリンクをコピーして
クリップボード経由等で取り込んでいたが、Notesの制御についてだいぶ分かって来たため、下記の実現にトライした。
文書のリストを直接取り込む
開いている文書の情報を登録または更新する
Access側の検索でヒットした文書を、Notesデータベースを開いて表示する
Option Compare Database
Option Explicit
'参照設定
'Lotus Domino Object
'Lotus Notes Automation Classese
Type notesDBinfo
server As String
dbName As String
End Type
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'☆ Form Moduleのコマンドボタンから実行
'**********************************************************************
'
' unidを元に、また、データベースのリストのテーブルを参照して
' dbFileNameと、T_DBlistを参照して、目的のノーツDBファイルを開き、目的文書にジャンプ
'
'**********************************************************************
Private Sub openNotesDocButton_Click()
Dim session As Object, DB As Object, doc As Object
Dim server As String, dbFile As String
Dim ws As Object, uidoc As Object
Dim docID As String
Dim AcDB As DAO.Database
Dim rs As DAO.Recordset
Dim strWhere As String
On Error GoTo errorHandle
Set AcDB = CurrentDb
Set rs = AcDB.OpenRecordset("T_DBlist", dbOpenDynaset)
rs.Filter = "DBname Like '" & Me.dbFileName & "'"
Set rs = rs.OpenRecordset
If Not IsNull(rs!server) Then server = rs!server
If Right(rs!dbpath, 1) = "\" Then
dbFile = rs!dbpath & rs!dbName
Else
dbFile = rs!dbpath & "\" & rs!dbName
End If
Set session = CreateObject("Notes.NotesSession")
Set ws = CreateObject("Notes.NotesUIWorkspace")
Set DB = session.GetDatabase(server, dbFile)
If Not DB.IsOpen Then DB.Open
docID = Me.unid
Set doc = DB.GetDocumentByUNID(docID)
Set uidoc = ws.EDITDOCUMENT(True, doc, False)
errorHandle:
If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
On Error GoTo 0
On Error Resume Next
Set DB = Nothing
Set session = Nothing
Set ws = Nothing
rs.Close
Set rs = Nothing
AcDB.Close
Set AcDB = Nothing
End Sub
'☆以下も実際には適当なフォームのボタンから実行する事になる
'**********************************************************************
'
'開いてるNotes文書をAccess側から起動したVBAでAccessDBに登録する
'NotesUI...はCOMでは使えないらしい
'
'**********************************************************************
Sub resistOpenDoc()
Dim notesDoc As Object 'NotesDocument
Dim ws As Object 'NotesUIWorkspace
Dim uidoc As Object 'NotesUIDocument
Dim AcDB As DAO.Database
Dim rs As DAO.Recordset
Dim strWhere As String
Dim qdf As DAO.QueryDef
Dim mySQL As String
Dim boolRet As Boolean
On Error GoTo errorHandle
Set ws = CreateObject("Notes.NotesUIWorkspace")
Set uidoc = ws.CURRENTDOCUMENT
Set notesDoc = uidoc.Document
Set AcDB = CurrentDb
'ワークテーブルの中味を消去,テンポラリクエリが存在すれば削除
AcDB.Execute ("DELETE FROM T_work")
If IsExistQ("Q_temp") Then AcDB.QueryDefs.Delete "Q_temp"
'目的の文書かチェック
If notesDoc.ParentDatabase.Title Like "*hoge*" Then
'UniversalIDで既存かどうかを判断
strWhere = "[unid] = '" & notesDoc.UniversalID & "'"
mySQL = "SELECT * FROM T_history WHERE " & strWhere & ";"
Set qdf = AcDB.CreateQueryDef("Q_temp", mySQL)
Set rs = AcDB.OpenRecordset("Q_temp")
If rs.RecordCount > 0 Then
'登録済みの時
If notesDoc.LastModified > rs!LastModified Then
'文書がDBに登録されたものより新しければ更新
rs.Edit
boolRet = setNotesDoc2RS(rs, notesDoc)
If boolRet Then rs.Update
End If
rs.Close
Set rs = Nothing
Else
'未登録の時 空のレコードセットを捨てて、ワークテーブルのレコードセットに置き換え
rs.Close
Set rs = Nothing
Set rs = AcDB.OpenRecordset("T_work", dbOpenTable)
rs.AddNew
boolRet = setNotesDoc2RS(rs, notesDoc)
If boolRet Then rs.Update
rs.Close
Set rs = Nothing
End If
'ワークテーブルを本テーブルに追加するクエリを実行して、データを追加
DoCmd.SetWarnings False
DoCmd.OpenQuery "Q_addData"
DoCmd.SetWarnings True
Set qdf = Nothing
AcDB.QueryDefs.Delete "Q_temp"
End If
errorHandle:
If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
On Error GoTo 0
On Error Resume Next
rs.Close
Set rs = Nothing
Set qdf = Nothing
Set AcDB = Nothing
Set ws = Nothing
End Sub
'**********************************************************************
'
' テーブルにリスト化した過去のノーツデータベースアーカイブ群から情報を取り込んで
' Accessのデータベースに取り込む（AccessのNotesDBのリストテーブルはは手動で追加および管理する）
' 巨大レコードセットを避けるため、ワークテーブルに入れて追加クエリする方法に変更した。
' UnidのWhere条件でレコードセットを取得し、空なら新規登録、あれば更新処理
' 注）SQLを都度生成して実行する方法は、S/Wクォーテーションを含む事も
' 考えられるメモ型を含みエラー発生の怖れありと判断してやめた
'
'**********************************************************************
'
'データ追加用 追加クエリ Q_addData の内容
'INSERT INTO T_history ( unid, 番号, ..., LastModified, dbFileName )
'SELECT T_work.unid, T_work.番号, ..., T_work.LastModified, T_work.dbFileName
'FROM T_work;
'T_DBlistのフィールド ID:AutoNumber, DBname:Text, Server:Text, DBpath:Text, inportFlag:Yes/No
Sub getDataFromNotesDB()
Dim AcDB As DAO.Database
Dim rs As DAO.Recordset
Dim i As Long
Dim notesDBlist() As notesDBinfo
Dim strWhere As String
Dim session As NotesSession
Dim password As String
Dim notesDB As NotesDatabase
Dim serverName As String
Dim notesDbName As String
Dim notesDoc As NotesDocument
Dim notesDocList As NotesDocumentCollection
Dim qdf As DAO.QueryDef
Dim mySQL As String
Dim boolRet As Boolean
On Error GoTo errHandle
password = "" '環境に合わせる、パスワードが必要な場合は、設定しておかないと都度ダイアログで訊いてくる。
Set AcDB = CurrentDb
'ワークテーブルの中味を消去
AcDB.Execute ("DELETE FROM T_work")
If IsExistQ("Q_temp") Then AcDB.QueryDefs.Delete "Q_temp"
Set session = CreateObject("Lotus.Notessession")
session.Initialize password
'データベースのリストのテーブルから、テーブル情報を構造体（の配列）に設定
notesDBlist = getNotesDBlist
For i = 1 To UBound(notesDBlist)
'ノーツデータベースのリストに対して処理
With notesDBlist(i)
serverName = .server
notesDbName = .dbName
End With
Set notesDB = session.GetDatabase(serverName, notesDbName)
If Not notesDB.IsOpen Then notesDB.Open
Set notesDocList = notesDB.AllDocuments
Set notesDoc = notesDocList.GetFirstDocument
Do Until notesDoc Is Nothing
'UniversalIDで既存かどうかを判断
strWhere = "[unid] = '" & notesDoc.UniversalID & "'"
mySQL = "SELECT * FROM T_history WHERE " & strWhere & ";"
Set qdf = AcDB.CreateQueryDef("Q_temp", mySQL)
Set rs = AcDB.OpenRecordset("Q_temp")
If rs.RecordCount > 0 Then
'登録済みの時
If notesDoc.LastModified > rs!LastModified Or notesDoc.ParentDatabase.FileName <> rs!dbFileName Then
'文書がDBに登録されたものより新しいか、データベース名が変わっているとき（アーカイブされているとき）
rs.Edit
boolRet = setNotesDoc2RS(rs, notesDoc)
If boolRet Then rs.Update
End If
rs.Close
Set rs = Nothing
Else
'未登録の時 空のレコードセットを捨てて、ワークテーブルのレコードセットに置き換え
rs.Close
Set rs = Nothing
Set rs = AcDB.OpenRecordset("T_work", dbOpenTable)
rs.AddNew
boolRet = setNotesDoc2RS(rs, notesDoc)
If boolRet Then rs.Update
rs.Close
Set rs = Nothing
End If
'追加クエリを実行して、データを追加
DoCmd.SetWarnings False
DoCmd.OpenQuery "Q_addData"
AcDB.Execute ("DELETE FROM T_work")
DoCmd.SetWarnings True
Set notesDoc = notesDocList.GetNextDocument(notesDoc)
Set qdf = Nothing
AcDB.QueryDefs.Delete "Q_temp"
DoEvents: DoEvents: DoEvents
Sleep 10
Loop
Set notesDB = Nothing
Next i
errHandle:
If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
On Error GoTo 0
'エラーが出てもとにかくオブジェクトを消去する
On Error Resume Next
Set notesDB = Nothing
Set session = Nothing
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
AcDB.QueryDefs.Delete "Q_temp"
AcDB.Close
Set AcDB = Nothing
End Sub
'**********************************************************************
'notesDocumentのデータをDAO.Recordsetにセットする関数
'エラーが無く終了すればTrueを戻す
'OLEからも呼べる様に、Notesのオブジェクトをオブジェクト型に変更
'**********************************************************************
'Function setNotesDoc2RS(rs As DAO.Recordset, notesDoc As NotesDocument) As Boolean
Function setNotesDoc2RS(rs As DAO.Recordset, notesDoc As Object) As Boolean
Dim buf As Variant
Dim stdName As String
Dim richItem As Object 'NotesRichTextItem
On Error GoTo errorHandle
'以下、field? は実際のフィールド名と置き換えてアレンジする。個数も代表的なフィールドタイプについて説明してあるのみで、実情に合わせる事。
rs!unid = notesDoc.UniversalID
rs!番号 = notesDoc.GetItemValue("Bango")(0) 'これはノーツDB側で設けている管理ナンバー
'要素が空である可能性のあるフィールドは一旦Variant型の配列に受けて、結果が配列であれば書き込み
buf = notesDoc.GetItemValue("field2")
If IsArray(buf) And buf(0) <> "" Then rs!Field2 = buf(0)
'名前の場合は、「CN=名字 名前/O=組織名」という形式から切り出し
stdName = notesDoc.GetItemValue("field3")(0)
rs!field3 = Replace(Split(stdName, "/")(0), "CN=", "")
'リッチテキストの場合は、オブジェクト型で受けて、結果がNothingか否かで分岐
Set richItem = notesDoc.GetFirstItem("field4")
If Not richItem Is Nothing Then rs!field4 = richItem.Text
'日付型フィールドに空文字列を代入しようとするとエラーになる
buf = notesDoc.GetItemValue("field5")
If IsArray(buf) And buf(0) <> "" Then rs!field5 = buf(0)
'バージョン管理のためnotesDocumentのLastModifiedプロパティを収納
rs!LastModified = notesDoc.LastModified
'ノーツのDocumentを呼び出す時使用するためにNotesデータベースのファイル名を記録
rs!dbFileName = notesDoc.ParentDatabase.FileName
setNotesDoc2RS = True
Exit Function
errorHandle:
setNotesDoc2RS = False
End Function
'**********************************************************************
' クエリの存在確認
' 異常終了時の再試行対策
'**********************************************************************
Private Function IsExistQ(strQuery As String) As Boolean
Dim defQ As DAO.QueryDef
IsExistQ = False
For Each defQ In CurrentDb.QueryDefs
If defQ.Name = strQuery Then
IsExistQ = True
Exit For
End If
Next defQ
Set defQ = Nothing
End Function
'**********************************************************************
' 取り込み対象のnotesDatabaseのリストを構造体の配列に取り込んで戻す
' Recordsetを複数開いてループをネストするのは煩雑なので、その対策
' 添字0は使っていない
'**********************************************************************
Private Function getNotesDBlist() As notesDBinfo()
Dim AcDB As DAO.Database
Dim rs As DAO.Recordset
Dim i As Long
Dim tempList() As notesDBinfo
Dim serverName As String, notesDbName As String, localPath As String
On Error GoTo errHandle
Set AcDB = CurrentDb
Set rs = AcDB.OpenRecordset("T_DBlist", dbOpenTable)
ReDim tempList(0 To 0)
i = 1
Do Until rs.EOF
If Not rs!inportFlag Then
ReDim Preserve tempList(0 To i)
If IsNull(rs!server) Then
serverName = ""
localPath = rs!dbpath
If Right(localPath, 1) <> "\" Then
notesDbName = localPath & "\" & rs!dbName
Else
notesDbName = localPath & rs!dbName
End If
Else
serverName = rs!server
notesDbName = rs!dbName
End If
With tempList(i)
.server = serverName
.dbName = notesDbName
End With
i = i + 1
End If
rs.MoveNext
Loop
getNotesDBlist = tempList
errHandle:
If Err.Number <> 0 Then Debug.Print Err.Number & Err.Description & Err.Source
On Error GoTo 0
On Error Resume Next
rs.Close
Set rs = Nothing
AcDB.Close
Set AcDB = Nothing
End Function