Domino 9 und frühere Versionen > ND6: Entwicklung
Dialogbox - Wert auswählen / setzen
Thomas Schulte:
Das hier stammt nicht von mir aber damit kannst du an the fly eine DC sortieren
Since getting having an unsorted DocumentCollection is generally a pain, I've
written some code that's pretty quick in sorting these documents on the fly.
This uses a QuickSort algorithm, instead of the much slower bubble sorts that
seem to be floating out here...
I actually borrowed the CollectionToArray code from this board a while back,
but it also used a bubble sort routine that was way too slow.
This code should be able to be used as is. I've used this method in several
DB's with no changes since the initial write. The only thing you should have
to change is the variable which tells it which field to sort on (explained
below)...
Sub CollectionToArray ( dc As NotesDocumentCollection)
Dim doc As NotesDocument
Dim k As Long
k = dc.Count
If k<>0 Then
Redim da( 1 To k+1) As NotesDocument
Set doc = dc.GetFirstDocument
For i=1 To k
Set da(i) = doc
Set doc = dc.GetNextDocument(doc)
Next
End If
'Need to add a value at the end that will always be greater than all
other values
Set da(k+1) = dirDB.CreateDocument
da(k+1).Lastname = "ZZZZZZZZ"
End Sub
Function swap(i As Integer,j As Integer) As Variant
Dim temp As NotesDocument
Set temp = da(i)
Set da(i) = da(j)
Set da(j) = temp
End Function
Sub QuickSort (leftpos As Integer, rightpos As Integer)
Dim i As Integer
Dim j As Integer
Dim pivot As String
If (leftpos < rightpos) Then
i=leftpos
j=rightpos + 1
pivot = da(leftpos).GetFirstItem(key).Text
Do
Do
i=i+1
Loop While da(i).GetFirstItem(key).Text<pivot And
i<=rightpos
Do
j=j-1
Loop While da(j).GetFirstItem(key).Text > pivot And
j>=leftpos
If (i<j) Then
Call swap(i, j)
End If
Loop While (i<j)
Call swap(leftpos,j)
Call QuickSort(leftpos,j-1)
Call QuickSort(j+1,rightpos)
End If
End Sub
These need to be public variables, so place them in your "Declarations":
Dim s As NotesSession
Dim db As NotesDatabase 'The current database
Dim da As Variant
Const key = "LastName" 'This the name of the FIELD you want to sort on
Now, how to use this stuff...
In your Initialize, or wherever you're calling this from:
1) Get your DocumentCollection (here: dc)
2) Call CollectionToArray(dc) 'just creates an array of your documents so that
we can re-order them
3) Call QuickSort(Lbound(da), Ubound(da)-1) 'actually sorts your documents
4) Redim Preserve da( 1 To Ubound(da)-1) As NotesDocument 'just chops off the
'ZZZZZ' value we needed as a 'high' value (see CollectionToArray routine)
5) Forall doc In da ... End ForAll 'Use this to loop through your sorted
documents
Remember, the DocumentArray (da) is just an array of documents, so you can
reference the 'doc' in your ForAll and any of it's properties, fields, etc.
just like any other document.
Let me know if you have any problems, or just to let me know you found this
useful...
Steve Held
Paxion Corporation
Anpassung:
Replace the
For i=1 To k
Set da(i) = dc.GetNthDocument(i)
Next
with the appropriate GetNextDocument() code instead for some addtl. speed.
GetNthDocument is much slower than GetNextDocument....
margli:
Danke werd ich mal testen. Ich hatte es vorher so:
Option Public
Option Declare
%REM ....................................CLASS Information: NotesDocumentArray
'Version: 0.8.7.0 (beta) 10/12/2001
'Created: By Andrew Tetlaw
'Creation Date: 03 Sep 2001
'PURPOSE: A more flexible document collection container than a document collection.
'The class gets around limitations in the R4 NotesDocumentCollection. With DocArray
'you can add document collections or add one document at a time to the array. It also
'has most of the methods and properties of the NotesDocumentCollection class with a
'few extras like SortBy and GetDocumentIndex.
'Re: Error handling: I just want it to ignore problems like a good little class and
'instead do nothing. For example if a function requires a NotesDocument as an argument
'and Nothing is passed (indicating a problem) the function just doesn't do anything
'rather than throwing an exception and messing up what ever routine called the class.
'This means that error checking must be done in the calling function.
'Based on work done by:
' Micheal Werry for the class idea and the AddCollection method
' Slade Swan for the bubble sort routine in the SortBy method
'contributions from:
' Tony Harrison: 'Sub KeepMatchingDocuments(itemname As String, text As String)'
%END REM
Class NotesDocumentArray
'## ===== PROPERTIES ==== ##
Public Array() As NotesDocument
Private Index As Integer
Private Srtd As Integer
Private SrtdBy As String
Public Property Get Count As Integer
Count = Me.Index
End Property
Public Property Get IsSorted As Integer
IsSorted = Me.Srtd
End Property
Public Property Get SortedBy As String
SortedBy = Me.SrtdBy
End Property
'// Returns first document in array
Public Property Get GetFirstDocument As NotesDocument
If Me.Index > 0 Then
Set GetFirstDocument = Me.Array(Lbound(Me.Array))
Else
Set GetFirstDocument = Nothing
End If
End Property
'// Returns last document in array
Public Property Get GetLastDocument As NotesDocument
If Me.Index > 0 Then
Set GetLastDocument = Me.Array(Ubound(Me.Array))
Else
Set GetLastDocument = Nothing
End If
End Property
'// Returns document at index <x>
Public Property Get GetNthDocument(x As Integer) As NotesDocument
If (x > 0) And (Me.Index >= x) Then
Set GetNthDocument = Me.Array(x-1)
Else
Set GetNthDocument = Nothing
End If
End Property
'// Returns document index number or 0 if not found
Public Property Get GetDocumentIndex(doc As NotesDocument) As Integer
Dim x As Integer
If Not (doc Is Nothing) Then '// Don't do anything for nothing!
For x = 1 To (Me.Index)
If Me.Array(x-1).UniversalID = doc.UniversalID Then
GetDocumentIndex = x
End If
Next
End If
End Property
'// Returns next document sfter supplied docs index otherwise nothing if there's no next doc
Public Property Get GetNextDocument(doc As NotesDocument) As NotesDocument
Dim x As Integer
If Not (doc Is Nothing) Then '// Don't do anything for nothing!
For x = 0 To Ubound(Me.Array)
If Me.Array(x).UniversalID = doc.UniversalID Then
If Ubound(Me.Array) > x Then
Set GetNextDocument = Me.Array(x+1)
End If
End If
Next
End If
End Property
'// Returns previous document before supplied docs index otherwise nothing if there's no prev doc
Public Property Get GetPrevDocument(doc As NotesDocument) As NotesDocument
Dim x As Integer
If Not (doc Is Nothing) Then '// Don't do anything for nothing!
For x = 0 To (Me.Index-1)
If Me.Array(x).UniversalID = doc.UniversalID Then
If Lbound(Me.Array) >= x-1 Then
Set GetPrevDocument = Me.Array(x-1)
End If
End If
Next
End If
End Property
'## ==== NEW ==== ##
'// Class New constructor
Public Sub New ()
Redim Me.Array(0)
Me.Index = 0
Me.Srtd = False
Me.SrtdBy = ""
End Sub
'## ==== Reset ==== ##
'// resets the doc array to empty
Public Sub Reset()
Redim Me.Array(0)
Me.Index = 0
Me.Srtd = False
Me.SrtdBy = ""
End Sub
'## ==== ADD DOCUMENT ARRAY ==== ##
'// Add another notes document array to the array
Public Sub AddArray(array2 As NotesDocumentArray)
If Not (array2 Is Nothing) Then '// Don't do anything for nothing!
If array2.Count > 0 Then '// Don't do anything if the array is empty!
Redim Preserve Me.Array(Me.Index + array2.Count -1)
Dim doc As NotesDocument
Dim x As Integer
For x = 1 To array2.Count
Set Me.Array(Me.Index + (x-1)) = array2.GetNthDocument(x)
Next
Me.Index = Me.Index + array2.Count
End If
End If
End Sub
'## ==== ADD DOCUMENT COLLECTION ==== ##
'// Add a notes document collection to the array
Public Sub AddCollection(dc As NotesDocumentCollection)
If Not (dc Is Nothing) Then '// Don't do anything for nothing!
If dc.Count > 0 Then '// don't add anything if the DC is empty!
Redim Preserve Me.Array(Me.Index + dc.Count -1)
Dim doc As NotesDocument
Dim x As Integer
For x = 1 To dc.Count
Set Me.Array(Me.Index + (x-1)) = dc.GetNthDocument(x)
Next
Me.Index = Me.Index + dc.Count
End If
End If
End Sub
'## ==== ADD DOCUMENT ==== ##
'// Add a document to the array
Public Sub AddDocument(doc As NotesDocument)
If Not (doc Is Nothing) Then '// Don't do anything for nothing!
Redim Preserve Me.Array(Me.Index) '// Me.Index will always be 1 above the ubound anyway so you don't need to +1
Set Me.Array(Me.Index) = doc
Me.Index = Me.Index + 1
End If
End Sub
'## ==== REMOVE DOCUMENT ==== ##
'// Remove a document from the array
Public Sub RemoveDocument(doc As NotesDocument)
Dim x As Integer
Dim y As Integer
Dim newArray() As NotesDocument
Dim sortfield As String
Dim dosort As Integer
If Not (doc Is Nothing) Then '// Don't do anything for nothing!
Redim newArray(0) '// Initialise
'// make a new array of documents excluding the one to remove
For x = 0 To (Me.Index-1)
If Not (Me.Array(x).UniversalID = doc.UniversalID) Then
Redim Preserve newArray(y)
Set newArray(y) = Me.Array(x)
y=y+1
End If
Next
'// reset the NotesDocumentArray and rebuild it from the new array of documents created above
'Didn't want to use Reset() because I didn't want to interfere with the sorting properties
Redim Me.Array(0)
Me.Index = 0
For x = 0 To Ubound(newArray)
Call Me.AddDocument(newArray(x))
Next
End If
End Sub
'## ==== REMOVE MATCHING DOCUMENTS ==== ##
'// Removes all document where item.text = text
Public Sub RemoveMatchingDocuments(itemname As String, text As String)
Dim x As Integer
Dim y As Integer
Dim newArray() As NotesDocument
Dim doc As NotesDocument
Dim item As NotesItem
Redim newArray(0) '// Initialise
'// make a new array of documents excluding the one to remove
For x = 0 To (Me.Index-1)
Set doc = Me.Array(x)
If Not (doc Is Nothing) Then
Set item = doc.GetFirstItem(itemname)
If Not (item Is Nothing) Then
If Not (item.Text = text) Then
Redim Preserve newArray(y)
Set newArray(y) = doc
y=y+1
End If
End If
End If
Next
'// reset the NotesDocumentArray and rebuild it from the new array of documents created above
'Didn't want to use Reset() because I didn't want to interfere with the sorting properties
Redim Me.Array(0)
Me.Index = 0
For x = 0 To Ubound(newArray)
Call Me.AddDocument(newArray(x))
Next
End Sub
'## === KEEP MATCHING DOCUMENTS ==== ##
Public Sub KeepMatchingDocuments(itemname As String, text As String)
Dim x As Integer
Dim y As Integer
Dim newArray() As NotesDocument
Dim doc As NotesDocument
Dim item As NotesItem
Redim newArray(0) '// Initialise
'// make a new array of documents excluding the one to remove
For x = 0 To (Me.Index-1)
Set doc = Me.Array(x)
If Not (doc Is Nothing) Then
Set item = doc.GetFirstItem(itemname)
If Not (item Is Nothing) Then
If (item.Text = text) Then
Redim Preserve newArray(y)
Set newArray(y) = doc
y=y+1
End If
End If
End If
Next
Redim Me.Array(0)
Me.Index = 0
For x = 0 To Ubound(newArray)
Call Me.AddDocument(newArray(x))
Next
End Sub
'## ==== SORT BY ==== ##
Public Sub SortBy(itemname As String)
Dim doc As NotesDocument
Dim doc1 As NotesDocument
Dim j As Integer
Dim i As Integer
Dim a As Variant
Dim b As Variant
Dim lngA As Long
Dim lngB As Long
Dim swap As Integer
'// Bubble sort
If Me.Index > 0 Then
For i=1 To (Me.Index-1) '// Outer loop for sort
j=i
Do While j>=1 '// Inner loop for sort
b = Me.Array(j).GetItemValue(itemname) '// i.e. order val of 2nd doc in pair
a = Me.Array(j-1).GetItemValue(itemname)'// i.e. i.e. order val of 1st doc in pair
If b(0)<a(0) Then '// if 2nd is lower than first swap them!
Set doc=Me.Array(j)
Set doc1=Me.Array(j-1)
Set Me.Array(j)=doc1
Set Me.Array(j-1)=doc
j=j-1 '// decrement so that previous 2nd doc be comes 1st: that is you compare 1 and 0, then 2 and 1, then 3 and 2...and so on
Else
Exit Do
End If
Loop
Next
Me.Srtd = True
Me.SrtdBy = itemname
End If
End Sub
'## ==== SET FIELD VALUE ==== ##
'// sets a specified field to a specified value in all docs in array
Public Sub SetFieldValue(itemname As String,itemvalue As Variant)
Dim doc As NotesDocument
Dim x As Integer
For x = 0 To (Me.Index-1)
Set doc = Me.Array(x)
If Not (doc Is Nothing) Then '// don't want to generate any errors.
Call doc.ReplaceItemValue(itemname,itemvalue)
Call doc.save(True,True)
End If
Next
End Sub
End Class
-----
dim starttime as notesdatetime("")
dim endtime as notesdatetime("")
Irgendwie will er das so ned ?
Thomas Schulte:
dann nimm halt das:
dim starttime as new notesdatetime("")
dim endtime as new notesdatetime("")
Und es ist kein Wunder wenn deine "geklaute" Routine langsam ist.
Erstens wird da ja auch ein BubbleSort verwendet und was lernt man in der Anfängerklasse für Programmierer?
Bubble Sort ist ganz nett, wenn man wenige Daten sortieren muss, aber wenn es mehr als sagen wir einmal hundert sind sollte man dann doch zu etwas effizienteren Methoden greifen.
Und zweitens schau dir mal die AddDocument Methode an, die du hoffentlich nicht verwendet hast um deine DC in das Array zu transformieren. Redim Preserve ist ein ziemlicher Performance und Speicherfresser.
Schlussfolgerung: Klauen darf man schon, aber verstehen was da passiert muss man trotzdem.
Thomas
margli:
Ich bin ja noch ganz am Anfang. Ich muß noch viel lernen. :) Ich habe es nicht geklaut. Es war frei zum download. Also als Beispiel oder so. Weiß ned mehr.
Thomas Schulte:
;D Alles was man sich aus dem Web oder aus Beispielen holt ist geklaut, auch wenn es frei verwendbar ist :-*
Aber verstehen muss man es trotzdem.
Welche Methode der Klasse hast du denn verwendet um deine DocumentCollection zu übergeben?
Thomas
Navigation
[0] Themen-Index
[#] Nächste Seite
[*] Vorherige Sete
Zur normalen Ansicht wechseln