DominoArea.org [Archive]

Synopsis de base de documents Lotus Notes - créé à 13:28:35 le 30/06/2005
Informations de bibliothèque de codes
Nom : Sort
Dernière modification : 31/05/2005 09:28:28
Code LotusScript :
Option Public

Code : Tout sélectionner

Private Const VersionLib = "3.1.0.0 Standard"
Dim SortedArray As Variant
Public Function QuickSort(sArray As Variant)
   Dim sA() As String   
   Dim j As Long
   Dim bottom As Long
   Dim top As Long
   bottom = Lbound ( sArray )
   top = Ubound ( sArray )
   Redim sA( bottom To top ) As String     
   For j = bottom To top
      sA ( j ) = sArray ( j )
   Next
     ' DoQS does a QuickSort if the Sublist is longer than 10 elements
     ' Thus, when DoQS finishes, all elements are within 10 spots of their correct location.
     ' For lists that are close to being in order, an Insertion Sort is much faster than a QuickSort, so we
     ' run through the whole thing once doing an Insertion Sort to finish tidying up the order.
   Call DoQS( sA, bottom, top )
   Call DoInsertSort ( sA, bottom, top )
'   SortedArray = sA
   sArray = sA
End Function
Sub DoQS( sA() As String, bottom As Long, top As Long )
     ' Called by QuickSort
     ' Uses Public variable sA  (array of string)
   Dim length As Long
   Dim i As Long
   Dim j As Long
   Dim Pivot As Long
   Dim PivotValue As String
   Dim t As String
   Dim LastSmall As Long
   length = top - bottom + 1
     ' Only do the QuickSort if the sublist is at least 10 items long
   If length > 10 Then
          ' Pivot is chosen approx. halfway through sublist.
          ' This gives us best speed if list is almost sorted already, and is no worse than any
          ' other choice if the list is in random order.
      Pivot = bottom + (length \ 2)   
          ' Move PivotValue out of the way
      PivotValue = sA( Pivot )
      sA ( Pivot ) = sA ( bottom )
      sA ( bottom ) = PivotValue
          ' LastSmall is the location of the last value smaller than PivotValue
      LastSmall = bottom
      For i = bottom + 1 To top
         If sA ( i ) < PivotValue Then
            LastSmall = LastSmall + 1
            t = sA ( i )
            sA ( i ) = sA ( LastSmall )
            sA ( LastSmall ) = t
         End If
      Next
          ' Move the PivotValue back
      t = sA ( LastSmall )
      sA ( LastSmall ) = sA ( bottom )
      sA ( bottom ) = t
      Pivot = LastSmall
          ' Now sort each side
      Call DoQS ( sA, bottom, Pivot - 1 )
      Call DoQS ( sA, Pivot + 1, top )
   End If
End Sub
Sub DoInsertSort ( sA() As String, Byval bottom As Long, Byval top As Long )   
   Dim i As Long
   Dim x As Long
   Dim v As String
   Dim Found As Integer
   For i = bottom+1 To top
      x = i
      v = sA (i )
      Do While (sA(x-1) > v)
         sA ( x ) = sA ( x-1 )
         x = x - 1
         If x=0 Then
            Exit Do
         End If
      Loop
      sA (x) = v
   Next
End Sub
Function ReturnSortVersion() As String
   ReturnSortVersion = VersionLib
End Function

Reprise de deux tips (un Invité + Franckyz)

Voici une bibliothèque de script qui permet de passer une collection de documents, le nom de l'item (champ) du document qui servira de clé de tri, ainsi que le type de données de la clé (a : alphabétique, n: numérique, d: date/heure).
Les 2 fonctions de tris peuvent être appelées indépendemment l'une de l'autre et renvoient toutes deux un tableau d'ids.


Abusez en sans hésitation !!!
##############################################

Code : Tout sélectionner

(Declarations)
Dim doc As NotesDocument
Dim tabClesStr() As String
Dim tabClesNum() As Double
Dim tabClesDate() As NotesDateTime
Dim tabIDs() As String
Dim cpt As Integer
Dim elem As Variant
Dim tempID As String
*********************************

Sub creerTabCles(coll As NotesDocumentCollection, itemCle As String, typeTri As String)
'détermination du type de tri   
   Select Case typeTri
   Case "a"
      Redim tabClesStr(coll.Count-1)
   Case "n"
      Redim tabClesNum(coll.Count-1)
   Case "d"
      Redim tabClesDate(coll.Count-1)
   End Select
   Redim tabIDs(coll.Count-1)
   
'remplissage du tableau des clés
   Set doc = coll.GetFirstDocument
   Do Until doc Is Nothing
      Select Case typeTri
      Case "a"
         tabClesStr(cpt) = doc.GetItemValue(itemCle)(0)
      Case "n"
         tabClesNum(cpt) = doc.GetItemValue(itemCle)(0)
      Case "d"
         Set tabClesDate(cpt) = New NotesDateTime(doc.GetItemValue(itemCle)(0))
      End Select   
      tabIDs(cpt) = doc.UniversalID
      cpt = cpt+1
      Set doc = coll.GetNextDocument(doc)
   Loop
   
End Sub

***************************************************************************************************


Function triAbulles(coll As NotesDocumentCollection, itemCle As String, typeTri As String) As Variant
'extraction du tableau des clés
   Call creerTabCles(coll, itemCle,typeTri)
   
'tri a bulles des éléments du tableau des clés
   For i=coll.Count-1 To 0 Step -1
      For j=1 To i
         Select Case typeTri
         Case "a"
            If tabClesStr(j-1) > tabClesStr(j) Then
               elem =  tabClesStr(j-1)
               tabClesStr(j-1) =  tabClesStr(j)
               tabClesStr(j) = elem
               
               tempID = tabIDs(j-1)
               tabIDs(j-1) = tabIDs(j)
               tabIDs(j) = tempID
               
            End If
            
         Case "n"
            If tabClesNum(j-1) > tabClesNum(j) Then
               elem =  tabClesNum(j-1)
               tabClesNum(j-1) =  tabClesNum(j)
               tabClesNum(j) = elem
               
               tempID = tabIDs(j-1)
               tabIDs(j-1) = tabIDs(j)
               tabIDs(j) = tempID
               
            End If
            
         Case "d"
            If tabClesDate(j-1).TimeDifference(tabClesDate(j)) > 0 Then
               Set elem =  tabClesDate(j-1)   
               Set tabClesDate(j-1) =  tabClesDate(j)   
               Set tabClesDate(j) = elem
               
               tempID = tabIDs(j-1)
               tabIDs(j-1) = tabIDs(j)
               tabIDs(j) = tempID
               
            End If
         End Select
      Next
   Next
   
   triAbulles = tabIDs
   
End Function

*******************************************************************************

Function triParSelection(coll As NotesDocumentCollection, itemCle As String, typeTri As String) As Variant
   Dim minimum As Integer
   
'extraction du tableau des clés
   Call creerTabCles(coll, itemCle,typeTri)
   
'tri par selection des éléments du tableau des clés
   For i=0 To coll.Count-1
      minimum = i
      For j=i To coll.Count-1
         Select Case typeTri
         Case "a"
            If tabClesStr(j) < tabClesStr(minimum) Then
               minimum = j
            End If
         Case "n"
            If tabClesNum(j) < tabClesNum(minimum) Then
               minimum = j
            End If
         Case "d"
            If tabClesDate(j).TimeDifference(tabClesDate(minimum)) < 0 Then
               minimum = j
            End If
         End Select
      Next
      
      Select Case typeTri
      Case "a"
         elem = tabClesStr(minimum)
         tabClesStr(minimum) = tabClesStr(i)
         tabClesStr(i) = elem
      Case "n"
         elem = tabClesNum(minimum)
         tabClesNum(minimum) = tabClesNum(i)
         tabClesNum(i) = elem
      Case "d"
         Set elem = tabClesDate(minimum)
         Set tabClesDate(minimum) = tabClesDate(i)
         Set tabClesDate(i) = elem
      End Select
      
      tempID = tabIDs(minimum)
      tabIDs(minimum) = tabIDs(i)
      tabIDs(i) = tempID
   Next
   
   triParSelection = tabIDs
   
End Function

en ajoutant un cpt=0 en entete de la fonction creerTabCles eh bien meme que ca marche mieux quand on appelle la fonction plusieurs fois !!!

merci

L'invité c'est toi Ogu ?

Une autre fonction de tri (origine la Sandbox d'IBM, Scott McIntosh)

Detailed Description:
Uses a shell sort algorithm to quickly sort an array. The code is in the Sort Test agent. The sub is ArraySort(). The code is shown below, but the agent also has code to demonstrate the routines use, test the routine, as well as compare it to a bubble sort. The speed difference is astounding.

============= Code =========================

Code : Tout sélectionner

''''''''''''''''''''''''''''''
' ArraySort
'
' Sorts an array of values using a Shell Sort algorthim (ported from' a C language algorthim).
'
' Scott McIntosh
' ICF Consulting
' Rights are given to freely distribute or modify this code in any
' way that is useful. If you make improvements I would appreciate
' hearing about them.
'
' I can be contacted at smcintosh@icfconsulting.com
'
' Arguments:
' Boolean descending
' If passed "true" the array is sorted in decending order, otherwise
' it is sorted in ascending order.
'
' Should work for any data type that can be compared with the "<" and
' ">" operators, and can be modified easily to allow for the custom
' sorting of any object.
'
Private Sub ArraySort( array As Variant, descending As Boolean)
Dim aSpans(1 To 9) As Integer
Dim nSpanCount As Integer
Dim nSpanIncr As Integer
Dim nLimit As Integer ' The number of items to sort
Dim nSpan As Integer
Dim KeyNum As Integer
Dim SwapEm As Integer
Dim SubArray(1 To 3) As Variant
Dim Record1Keys As Variant
Dim Record2Keys As Variant
Dim doc As notesDocument
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Temp As Variant
Dim floor As Integer

'Define the spans used by the algorthim
aSpans(1) = 9840
aSpans(2) = 3279
aSpans(3) = 1093
aSpans(4) = 364
aSpans(5) = 121
aSpans(6) = 40
aSpans(7) = 13
aSpans(8) = 4
aSpans(9) = 1

'The max spans possible
nSpanCount = 9

'Which span to start on
nSpanIncr = 1
floor = Lbound( array ) '' we use this a lot so store it

nLimit = Ubound( array ) - floor

If nLimit = 1 Then
'No need to sort a single element array
Exit Sub
End If

' Determine how many spans we'll have to make.
' this will depend on the number of elements to sort
j = floor
For k = nSpanCount To 1 Step -1
If aSpans(k) > nLimit Then
' The span exceeds the number of elements, exiting now retains the
' last span index, which will be the largest span less than the count
Exit For
End If
j = k
Next

i = j

For i = j To nSpanCount ' nSpanCount is the max number of spans we
' could make i is the first number from
' aSpans tha was less than the total
' number of documents
nSpan = aSpans(i )

For j = nSpan To nLimit
Temp = array(j)
k = j - nSpan

Do While k >= floor

' Compare and setermine if the values need swapped
Dim doSwap As Boolean

' Determine which comparison to make based on the
' value of the argument passed in descending
If descending Then
doSwap = Temp > array(k)
Else
doSwap = Temp < array(k)
End If

' If the comparison indicates they need swapped then
' do it
If doSwap Then
' Swap 'em
array(k + nSpan) = array(k)
k = k - nSpan
Else
Exit Do
End If

Loop

array( k + nSpan ) = Temp

Next j
Next i

End Sub