任何使用设计不佳/维护良好的Lotus Notes数据库的人都可以证明，并非所有具有相同表格名称的记录都具有相同数量的项目，甚至是项目顺序。
需要将整个数据库导出为CSV文件以进行迁移，并且我已经整理了来自不同论坛的片段和片段。博客来实现这一目标。
我有一个有效的代码模型，但需要手动编辑才能为每个表单创建一个集合。哪个好，但不像我喜欢的那样整洁。
有没有人知道根据从主集合/记录中检索的数据动态创建新集合的方法。
整个代码集在
之下 'Whole database export via collection with Sorted items, created by CodeJack
'Export CSV based on http://searchdomino.techtarget.com/tip/How-to-export-data-from-a-Lotus-Notes-database-to-a-CSV-file
'sortValues based on http://per.lausten.dk/domino/sortNotesDocumentCollection.html
Sub Initialize
On Error Goto processerror
Dim session As New NotesSession
Dim dbPri As NotesDatabase
Dim ws As New NotesUIWorkspace
Dim dc As NotesDocumentCollection
Dim docPri As NotesDocument
Dim curView As NotesUIView
Dim NumRec As String
Dim msgOutputs As String
'Get useable date and time values for file naming
Dim fDate As String
Dim fTime As String
If Month(Date()) < 10 Then
If Day(Date()) < 10 Then
fDate = Year(Date()) & "0" & Month(Date()) & "0" & Day(Date())
Else
fDate = Year(Date()) & "0" & Month(Date()) & Day(Date())
End If
Else
If Day(Date()) < 10 Then
fDate = Year(Date()) & Month(Date()) & "0" & Day(Date())
Else
fDate = Year(Date()) & Month(Date()) & Day(Date())
End If
End If
fTime = Hour(Time()) & "-" & Minute(Time())
'Set the NewLine variable for breaking message boxes
Dim NewLine As String
NewLine = Chr(10)+Chr(13)
'declare the Pri database
Set dbPri = session.CurrentDatabase
Set curView = ws.CurrentView
'Set the Primary DB collection to retrieve the list of selected documents in the view
Set dc = curView.Documents
'Collection1s collection
Dim dcCollection1 As NotesDocumentCollection
Dim docCollection1 As NotesDocument
Dim NumCollection1 As String
'Collection2 collection
Dim dcCollection2 As NotesDocumentCollection
Dim docCollection2 As NotesDocument
Dim NumCollection2 As String
'Open collections
If dbPri.IsOpen Then
Set dcCollection1 = dbPri.CreateDocumentCollection
Set dcCollection2 = dbPri.CreateDocumentCollection
Else
Msgbox "Database has not been opened"
Exit Sub
End If
'Set Export path
Dim sFilepath As String
Dim sFilename As String
sFilepath = "C:\Data\Testing\"
'Continue if collection has documents
NumRec = dc.Count
If NumRec > 0 Then
msgOutputs = NumRec & " records processed." & NewLine
'Split out documents to their individual Collections
If (Not dc Is Nothing) Then
For a = 1 To dc.Count 'a = all documents
Set docPri = dc.GetNthDocument(a)
'Assign document to relevant collection based on the form name
If docPri.Form(0) = "VID" Then
Call dcCollection1.AddDocument (docPri)
Elseif docPri.Form(0) = "SI" Then
Call dcCollection2.AddDocument (docPri)
End If
Next
End If
Else
Msgbox "No records in collection"
Exit Sub
End If
'Process Collection1
'Count # of records in collection
NumCollection1 = dcCollection1.Count
'Continue if collection has documents
If NumCollection1 > 0 Then
'Compile output message
msgOutputs = msgOutputs & NumCollection1 & " - " & dcCollection1.GetFirstDocument.Form(0) & "'s" & NewLine
'Set the export filename
sFilename = dcCollection1.GetFirstDocument.Form(0) & "_" & fDate &"_" & fTime & ".csv"
'Export Collection
Call exportCSV(dcCollection1, sFilepath, sFilename)
End If
'Process Collection2
NumCollection2 = dcCollection2.Count
'Continue if collection has documents
If NumCollection2 > 0 Then
'Compile output message
msgOutputs = msgOutputs & NumCollection2 & " - " & dcCollection2.GetFirstDocument.Form(0) & "'s" & NewLine
'Set the export filename
sFilename = dcCollection2.GetFirstDocument.Form(0) & "_" & fDate &"_" & fTime & ".csv"
'Export Collection
Call exportCSV(dcCollection2, sFilepath, sFilename)
End If
'Display output message to user
Msgbox msgOutputs
Exit Sub
processerror:
If Err <> 0 Then
Msgbox "Initialize: ERROR on line " & Cstr(Erl) & " (" & Cstr(Err) & ") - " & Error$
Exit Sub
End If
End Sub
Sub exportCSV(col As NotesDocumentCollection, sFilepath As String, sFilename As String)
'CSV write method based on http://searchdomino.techtarget.com/tip/How-to-export-data-from-a-Lotus-Notes-database-to-a-CSV-file
'Altered by Andrew Lambert to fit purpose of sorting and exporting all items on documents in a collection
On Error Goto processerror
Dim datadoc As NotesDocument
Dim sorteddoc As NotesDocument
Dim db As NotesDatabase
Dim session As New NotesSession
Dim fileNum As Integer
Dim fileName As String
Dim headerstring As String
Dim values As String
Dim item As NotesItem
Dim ItemName As String
Dim arSort As Variant
Set db = session.CurrentDatabase
fileNum% = Freefile()
fileName$ = sFilepath & sFilename
Open fileName$ For Output As fileNum%
'Build Files
If (Not col Is Nothing) Then
For i = 1 To col.Count
Set datadoc = col.GetNthDocument(i)
'Write record header to file
Forall x In datadoc.Items
If x.type = 1084 Or x.name = "Photograph" Or x.name = "Signature" Then 'Skip data types / fields which cant be exported via CSV
'Do nothing
Else
headerstring=headerstring & |"| & x.name &|",| 'Create header string for the record
End If
End Forall
'remove trailing comma
headerstring=Left(headerstring,Len(headerstring)-1)
'break headerstring into components for array
arSort = Split(headerstring,",")
'Sort array alphabetically
arSort = sortValues(arSort)
'Compile sorted array back into string
headerstring = Implode(arSort,",")
'remove trailing "
headerstring=Left(headerstring,Len(headerstring)-1)
'Write to file
Write #fileNum%, |Header","UNID",| & headerstring & ||
headerstring=""
'Create sorted document for exporting data, this is needed as you can't sort the values of the items separate from the item names
Set sorteddoc = db.CreateDocument
'Loop through sorted array of item names
Forall z In arSort
ItemName = Replace(z,|"|,||) 'Remove quotations to avoid ADT error
'Copy item from source document to destination in alphabetical order
Call sorteddoc.CopyItem(datadoc.GetFirstItem(ItemName),ItemName)
End Forall
'Write record data to file
'loop through all document items
Forall x In sorteddoc.Items
'retrieve item value
values=values & |"| & x.text &|",|
End Forall
'Write to file
Write #fileNum%, |Data",| & |"| & sorteddoc.UniversalID & |",| & values & |"|
values=""
Next
End If
Close fileNum%
Exit Sub
processerror:
If Err <> 0 Then
Msgbox "Export CSV: ERROR on line " & Cstr(Erl) & " (" & Cstr(Err) & ") - " & Error$
Exit Sub
End If
End Sub
Function sortValues(varValues As Variant) As Variant
'from http://per.lausten.dk/domino/sortNotesDocumentCollection.html
On Error Goto errHandler
' Use Shell sort to sort input array and return array sorted ascending
Dim k As Integer
Dim i As Integer
Dim j As Integer
Dim h As Integer
Dim r As Integer
Dim temp As String
'Set up for Shell sort algorithm
k = Ubound( varValues )
h = 1
Do While h < k
h = (h*3)+1
Loop
h = (h-1)/3
If h > 3 Then
h = (h-1)/3
End If
'Shell sort algorithm
Do While h > 0
For i = 1+h To k
temp = varValues(i)
j = i-h
Do While j >0
If varValues(j)>temp Then
varValues(j+h) = varValues(j)
varValues(j) = temp
Else
Exit Do
End If
j = j-h
Loop
Next i
h = (h-1)/3
Loop
'Write new sorted values
sortValues = varValues
getOut:
Exit Function
errHandler:
Dim strMsg As String
strMsg = "SortValues: Error #" & Err & Chr$(10) & Error$ & Chr$(10) & "Line #" & Erl & | in sub/function: "| & Lsi_info(2) & |"|
Msgbox strMsg, 16, "Unexpected error"
sortValues = "ERROR"
Resume getOut
End Function
答案 0 :(得分：2)
首先：不要在NotesDocumentCollections上使用GetNthDocument，它会让事情变得非常缓慢，因为它从每一轮的0开始计算......时间消耗随着集合的大小呈指数增长。
而不是
For i = 1 to dc.Count
Set doc = dc.GetNthDocument(i)
Next
使用
Set doc = dc.GetFirstDocument()
While not doc is Nothing
'- do your stuff here
Set doc = dc.GetNextDocument(doc)
Wend
也就是说，有不同的方法来创建集合。
我建议使用集合列表完全灵活：
Dim ldc List as NotesDocumentCollection
如果您有要在数组中导出的表单的名称（示例中为varForms），那么您可以执行以下操作：
Forall strForm in varForms
Set ldc( strForm ) = dbPri.Search( {Form = "} & strForm & {"}, Nothing, 0)
End Forall
正如Richard（thanx）的评论中所述，您可以使用
简单地获取数据库中的所有表单varForms = dbPri.Forms
这样您就不需要包含要导出的所有文档的视图。
如果你想＆＃34;拆分＆＃34;现有的集合（如您的示例中所示）您可以执行以下操作：
Set doc = dc.GetFirstDocument()
While not doc is Nothing
strForm = doc.GetitemValue( "form" )(0)
If Not iselement( ldc( strForm ) ) then
Set ldc( strForm ) = dbPri.CreateDocumentCollection
End If
Call ldc(strForm).AddDocument( doc )
Set doc = dc.GetNextDocument(doc)
Wend
稍后您可以浏览所有集合：
Forall dcForm in ldc
Set docWork = dcForm.GetFirstDocument()
While not docWork is Nothing
'- do your stuff here
Set docWork = dcForm.GetNextDocument(docWork)
Wend
End Forall
希望能给你一个起点