0
因爲任何使用設計不當的/維護良好的Lotus Notes數據庫的人都可以證實，並非所有具有相同表單名稱的記錄具有相同數量的項目，甚至項目順序。導出爲CSV - 使用排序項目收集的所有文檔
需要將整個數據庫導出到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
而且他可以簡單地通過引用dbPri.Forms來填充varForms。 –
你說得對。在帖子中增加了這個事實。感謝名單 –