<!--shcode--><pre><code class='ls'>Public Const CONST_ASCENDING=True
Public Const CONST_DESCENDING=False
Private db As NotesDatabase
'########### FieldContainer - класс поля MirrorDoc ##############################
' Value- массив значений поля
Public Class FieldContainer
Public Value() As String
Private i As Integer
Sub New
Me.i=0
End Sub
Sub Delete
Erase Me.Value
End Sub
'Добавления значения поля _________________________________________________
Public Sub AddValue(Value As String)
On Error Goto eh
Redim Preserve Me.Value(Me.i) As String
Me.Value(Me.i)=Value
Me.i=Me.i+1
ex: Exit Sub
eh: Msgbox Error + " in " + Cstr(Getthreadinfo(1))+"(FieldContainer class) on line " + Cstr(Erl)
Resume ex
End Sub
End Class
'########### MirrorDoc - вспомогательный класс ##############################
' Хранит в себе сортируемые значения полей документа в коллекции,
' а также значения полей документа для дальнейшего использования
'sortField() - ключи сортировки
'sortFieldValue - составной ключ сортировки
'field - список полей для дальнейшего использования
'UNID - UniversalId документа
Public Class MirrorDoc
Private sortField() As String
Public sortFieldValue As String
Public field List As FieldContainer
Private ID As String
Private i As Integer
Sub New(ID As String)
Me.i=0
Me.ID=ID
End Sub
Sub Delete
Erase Me.sortField
Erase Me.field
End Sub
Public Function Document As NotesDocument
On Error 4091Goto eh
Set Document=db.GetDocumentByID(Me.ID)
ex: Exit Function
eh: Set Document=Nothing
Resume ex
End Function
'Добавления значения поля(ключа сортировки)______________________________
Public Sub AddSortField(sortFieldValue As Variant)
On Error Goto eh
Dim temp As String
If Isnumeric(sortFieldValue) Then
temp=Cstr(Format(sortFieldValue, "yyyy/mm/dd : hh/nn/ss"))
Else
temp=sortFieldValue
End If
Redim Preserve Me.sortField(Me.i) As String
Me.sortField(Me.i)=temp
Me.i=Me.i+1
ex: Exit Sub
eh: Msgbox Error + " in " + Cstr(Getthreadinfo(1))+"(MirrorDoc class) on line " + Cstr(Erl)
Resume ex
End Sub
'Добавления поля со значением, для дальнейшего использования__________________
Public Sub AddFieldValue(fieldName As String, fieldValue As Variant)
On Error Goto eh
If Not Iselement(Me.field(fieldName)) Then Set Me.field(fieldName)=New FieldContainer
If Isarray(fieldValue) Then
Forall fv In fieldValue
Call Me.field(fieldName).AddValue(Cstr(fv))
End Forall
Else
Call Me.field(fieldName).AddValue(Cstr(fieldValue))
End If
ex: Exit Sub
eh: Msgbox Error + " in " + Cstr(Getthreadinfo(1))+"(MirrorDoc class) on line " + Cstr(Erl)
Resume ex
End Sub
'Сборка составного ключа________________________________________________
Public Sub FinalizeSortFields
Me.sortFieldValue=Join(Me.sortField)
End Sub
End Class
'############### PROTOTYPE_SORT - главный класс сортировки ########################
' Сортирует по ключам список вспомогательных объектов(СВО),
' при необходимости возвращает отсортированную коллекцию документов, получая их по UniversalId
' Также возвращает сам СВО, с используемыми в дальнейшем значениями указанных полей
' bufferDoc - Сортируемый СВО
' sortMode - порядок сортировки
Public Class PROTOTYPE_SORT
Public bufferDoc List As MirrorDoc
Private sortMode As Boolean
Sub New
Dim s As New NotesSession
Set db=s.CurrentDatabase
End Sub
Sub Delete
Call Truncate()
End Sub
' Очистка СВО___________________________________________________________________
Private Sub Truncate
Erase Me.bufferDoc
End Sub
' Сортировка___________________________________________________________________
'col - входная коллекция
'keyToSort() - массив ключей(название полей) для сортировки
'sortMode - порядок сортировки
'keyToBuffer - поля документа, значения которых необходимо поместить в вспомогательный объект
Public Sub Sort(col As NotesDocumentCollection, keyToSort() As String, sortMode As Boolean, keyToBuffer() As String)
On Error Goto eh
Call Truncate()
Dim doc As NotesDocument
Dim i As Long, maxCount As Long
Dim IsBufferUsed As Boolean 'не возвращать коллекцию документов
Me.sortMode=sortMode
maxCount=col.Count
If maxCount=0 Then Goto ex
If Not Isarray(keyToSort) Then Msgbox "Нет ключей для сортировки!" : Goto ex
If keyToSort(0)="" Then Msgbox "Нет ключей для сортировки!" : Goto ex
If Isarray(keyToBuffer) Then
IsBufferUsed=Not(keyToBuffer(0)="")
Else
IsBufferUsed=False
End If
Set doc=col.GetFirstDocument
For i=1 To maxCount
Set Me.bufferDoc(i)=New MirrorDoc(doc.NoteID)
Forall kts In keyToSort
Call Me.bufferDoc(i).AddSortField(doc.GetItemValue(kts)(0))
End Forall
Call Me.bufferDoc(i).FinalizeSortFields
If IsBufferUsed Then
Forall ktb In keyToBuffer
Call Me.bufferDoc(i).AddFieldValue(ktb, doc.GetItemValue(ktb))
End Forall
End If
Set doc=col.GetNextDocument(doc)
Next
Set doc=Nothing
Set col=Nothing
If Not QuickSort(1, maxCount) Then Msgbox "Не удалось произвести сортировку!"
ex: Exit Sub
eh: Msgbox Error + " in " + Cstr(Getthreadinfo(1))+"(PROTOTYPE_SORT class) on line " + Cstr(Erl)
Resume ex
End Sub
'Быстрая сортировка(QuickSort итерационный вариант)______________________________________________________
'http://www.codeproject.com/KB/recipes/IterativeQuickSort.aspx
'By Pete Goodsall 25 Jan 2008
Private Function QuickSort(nFirst As Long, nLast As Long) As Boolean
QuickSort=False
On Error Goto eh
Dim i As Long, j As Long, nStkPtr As Long, nStackMax As Long
Dim nTmp As MirrorDoc
Dim bSortCompleted As Boolean, bDirection As Boolean
bSortCompleted=False
bDirection=True
nStackMax=(Log(nLast)+3)*2
Dim nStack() As Long
Redim nStack(nStackMax,2) As Long
Do
Do
i=nFirst
j=nLast
bDirection=True
Do
If compare(Me.bufferDoc(i).sortFieldValue, Me.bufferDoc(j).sortFieldValue) Then
Set nTmp=Me.bufferDoc(i)
Set Me.bufferDoc(i)=Me.bufferDoc(j)
Set Me.bufferDoc(j)=nTmp
bDirection=Not bDirection
End If
If bDirection Then j=j-1 Else i=i+1
Loop While(i<j)
If i+1<nLast Then
nStkPtr=nStkPtr+1
nStack(nStkPtr,0)=i+1
nStack(nStkPtr,1)=nLast
End If
nLast=i-1
Loop While(nFirst<nLast)
If nStkPtr=0 Then
bSortCompleted=True
Else
nFirst=nStack(nStkPtr,0)
nLast=nStack(nStkPtr,1)
nStkPtr=nStkPtr-1
End If
Loop While(Not bSortCompleted)
QuickSort=True
ex: Exit Function
eh: Msgbox Error + " in " + Cstr(Getthreadinfo(1))+"(PROTOTYPE_SORT class) on line " + Cstr(Erl)
Resume ex
End Function
'Сравнение двух значений___________________________________
Private Function Compare(value1 As String, value2 As String) As Boolean
If Me.sortMode Then 'По возрастанию
Compare=Strcompare(value1, value2)>0
Else 'По убыванию
Compare=Strcompare(value2, value1)>0
End If
End Function
End Class[/CODE]
<div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">Применение</div></div><div class="sp-body"><div class="sp-content"><!--shcode--><pre><code class='ls'> Dim s As New NotesSession
Dim col As NotesDocumentCollection
Dim doc As NotesDocument
Dim PS_S As New PROTOTYPE_SORT
Dim key(0) As String
Dim buf(0) As String
Set col=s.CurrentDatabase.AllDocuments
key(0)="ReportNumber"
'buf-должен быть пустым, иначе нам вернет пустую коллекцию
Call PS_S.Sort(col,key, CONST_ASCENDING, buf)
fileNum% = Freefile()
Open "c:\1.txt" For Output As fileNum%
Forall p In PS_S.bufferDoc
set doc=p.Document
Print #fileNum%, doc.ReportNumber(0)+" "+doc.RunUser(0)
End Forall[/CODE]
<div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">Применение, с использованием буфера значений полей</div></div><div class="sp-body"><div class="sp-content"><!--shcode--><pre><code class='ls'> Dim s As New NotesSession
Dim col As NotesDocumentCollection
Dim doc As NotesDocument
Dim PS_S As New PROTOTYPE_SORT
Dim key(0) As String
Dim buf(1) As String
Set col=s.CurrentDatabase.AllDocuments
key(0)="ReportNumber"
buf(0)="RunUser"
buf(1)="ReportNumber"
Call PS_S.Sort(col,key, CONST_ASCENDING, buf)
fileNum% = Freefile()
Open "c:\1.txt" For Output As fileNum%
Forall p In PS_S.bufferDoc
Print #fileNum%, p.field("ReportNumber").Value(0)+" "+p.field("RunUser").Value(0)
End Forall[/CODE]
