Tri d'une collection de documents

[Michael DELIQUE]

Merci à BillBock pour son code

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

[Michael DELIQUE]

une autre Version

Code : Tout sélectionner

Public Function SortingCollection(Collection As NotesDocumentCollection,Critere As String,Sens As String) As Variant
   
   'Déclaration Variable   
   Dim nbUBound As Long
   Dim nbLbound As Long
   Dim tbDoc() As NotesDocument
   Dim Doc As NotesDocument
   
   On Error Goto ErreurHandle
   
   If Trim(Critere) = "" Then
      Exit Function
   End If   
   
   If Collection Is Nothing Then
      Exit Function
   Else
      Select Case Collection.count
      Case 0
         Set SortingCollection = Nothing
      Case 1
         Redim tbDoc(1)
         Set tbDoc(1) = Collection.GetFirstDocument
         SortingCollection = tbDoc
         Erase tbDoc
         Exit Function
      Case 2
         Redim tbDoc(1 To 2)
         Set tbDoc(1)= Collection.GetFirstDocument
         Set tbDoc(2) = Collection.GetLastDocument
         Select Case Ucase(Trim(Sens))
         Case "DECROISSANT","D","DESCENDANT","<"
            If  tbDoc(2).GetItemValue(Trim(Critere))(0) >  tbDoc(1).GetItemValue(Trim(Critere))(0) Then
               Set Doc= tbDoc(1)
               Set tbDoc(1) = tbDoc(2)
               Set tbDoc(2) = Doc
               Set Doc= Nothing
            End If
         Case Else '"CROISSANT","C","A","ASCENDANT","",">"
            If tbDoc(1).GetItemValue(Trim(Critere))(0) > tbDoc(2).GetItemValue(Trim(Critere))(0) Then
               Set Doc= tbDoc(1)
               Set tbDoc(1) = tbDoc(2)
               Set tbDoc(2) = Doc
               Set Doc= Nothing
            End If
         End Select
         Set Doc = Nothing
         SortingCollection = tbDoc
         Erase tbDoc
         Exit Function
         
      Case Else
         'on fait rien         
      End Select
   End If
   
   nbLBound = 1
   nbUBound = Clng(Collection.Count)
   
   Redim tbDoc(nbLBound To nbUBound )
   
   Set Doc = Collection.GetFirstDocument
   While Not Doc Is Nothing
      Set tbDoc(nbLBound) = Doc
      nbLBound=nbLBound+1
      Set Doc = Collection.GetnextDocument(Doc)
   Wend
   nbLBound = 1
   
   If nbUBound < 50 Then
      Call SortShellDocument(tbDoc,Trim(Critere))
   Else
      Call SortIntroDocument(tbDoc,Trim(Critere),nbLBound,nbUBound)
   End If
   
   
   Select Case Ucase(Trim(Sens))
   Case "DECROISSANT","D","DESCENDANT","<"
      nbLBound = 1
      nbUBound = Clng(Collection.Count)
      
      While nbLBound  < nbUBound
         Set Doc = tbDoc(nbLBound)
         Set tbDoc(nbLBound) = tbDoc(nbUBound)
         Set tbDoc(nbUBound) = Doc
         Set Doc = Nothing
         nbLBound= nbLBound + 1
         nbUBound = nbUBound - 1
      Wend      
      
   Case Else   '"CROISSANT","C","A","ASCENDANT","",">"
      SortingCollection = tbDoc
   End Select
   
   Erase tbDoc
   
   Exit Function
ErreurHandle:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"   
   Set SortingCollection = Nothing
   Exit Function
End Function


Code : Tout sélectionner

Sub SortIntroDocument( vrArray As Variant,Critere As String, nbLBound As Long, nbUBound As Long)
   
   'Tri par "QuickSort Recursif ou Introspection" récursif par ordre Croissant
   
   'Déclaration Variables
   Dim nbLow As Long
   Dim nbHigh As Long
   Dim DocPivot As NotesDocument
   Dim DocTable As NotesDocument
   
   On Error Goto ErreurHandle
   
   If Trim(Critere) = "" Then
      Exit Sub
   End If   
   
   Select Case Datatype(vrArray)
   Case 0,1,9,10 ' EMPTY,NULL,OLE object or NOTHING
      'error 9999,"vrArray is Nothing"
      Exit Sub
   Case Else
      If Isarray(vrArray)= False  Then
         Error 9999,"vrArray is not a Array"
         Exit Sub
      End If         
   End Select   
   
   'si les deux bound sont a zero = premiere itération donc renseignement
   If nbLBound = 0 Then
      If nbUBound = 0 Then
         nbLBound = Lbound(vrArray)
         nbUBound = Ubound(vrArray)
      End If
   End If
   
   If nbUBound = nbLbound Then
       'si 1 seule donnée pas de traitement
      Exit Sub
   Elseif nbUBound = (nbLbound+1) Then
       'si uniquement 2 données
      If vrArray(nbLbound).GetItemValue(Trim(Critere))(0) > vrArray(nbUBound).GetItemValue(Trim(Critere))(0) Then
         Set DocPivot = vrArray(nbUBound)
         Set vrArray(nbUbound) =  vrArray(nbLBound)
         Set vrArray(nbLBound) = DocPivot
         Set DocPivot = Nothing
      End If
      Exit Sub
   End If
   
   Set DocTable = Nothing
   Set DocPivot = Nothing
   
   nbLow = nbLBound
   nbHigh = nbUBound
   If ( nbUBound > nbLBound) Then
      Set DocPivot = vrArray( (nbLBound + nbUBound) /2)
      While ( nbLow <= nbHigh )
         Set DocTable = vrArray(nbLow)
         While (nbLow < nbUBound) And (DocTable.GetItemValue(Trim(Critere))(0) < DocPivot.GetItemValue(Trim(Critere))(0))
            nbLow = nbLow+1
         Wend
         Set DocTable = vrArray(nbHigh)
         While ( nbHigh > nbLBound ) And ( DocTable.GetItemValue(Trim(Critere))(0) > DocPivot.GetItemValue(Trim(Critere))(0))
            nbHigh = nbHigh - 1
         Wend
         
         Set DocTable = Nothing
         
         If ( nbLow <= nbHigh ) Then
            Set DocTable = vrArray(nbLow)
            Set vrArray(nbLow) = vrArray(nbHigh)
            Set vrArray(nbHigh) = DocTable
            Set DocTable = Nothing
            nbLow = nbLow+1
            nbHigh = nbHigh -1
         End If
      Wend
      Set DocPivot = Nothing
      If( nbLBound < nbHigh ) Then
         Call SortIntroDocument( vrArray,Trim(Critere), nbLBound, nbHigh )
      End If
      If( nbLow < nbUBound ) Then
         Call SortIntroDocument( vrArray,Trim(Critere), nbLow, nbUBound )
      End If
   End If
   
   Set DocTable = Nothing
   Set DocPivot = Nothing
   
   Exit Sub
ErreurHandle:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   
   Exit Sub
End Sub

Code : Tout sélectionner

Sub SortShellDocument(vrArray As Variant,Critere As String)
   'Tri par shell par ordre croissant
   
   'Déclaration Variables
   Dim nbUbound As Long
   Dim nbLbound As Long
   Dim nbGap As Long
   Dim i As Long
   Dim J As Long
   Dim vrValue As Variant
   Dim DocPivot As NotesDocument
   
   On Error Goto ErreurHandle
   
   If Trim(Critere) = "" Then
      Exit Sub
   End If   
   
   Select Case Datatype(vrArray)
   Case 0,1,9,10 ' EMPTY,NULL,OLE object or NOTHING
      'error 9999,"vrArray is Nothing"
      Exit Sub
   Case Else
      If Isarray(vrArray)= False  Then
         Error 9999,"vrArray is not a Array"
         Exit Sub
      End If         
   End Select   
   
   nbLbound = Lbound(vrArray)
   nbUBound = Ubound(vrArray)
   
   If nbUBound = nbLbound Then
      'si 1 seul donné pas de traitement
      Exit Sub
   Elseif nbUBound = (nbLbound+1) Then
        'si uniquement 2 données
      If vrArray(nbLbound).GetItemValue(Trim(Critere))(0) > vrArray(nbUBound).GetItemValue(Trim(Critere))(0) Then
         Set DocPivot = vrArray(nbUBound)
         Set vrArray(nbUbound) =  vrArray(nbLBound)
         Set vrArray(nbLBound) = DocPivot
         Set DocPivot = Nothing
      End If
      Exit Sub
   End If   
   
   Set DocPivot = Nothing
   
   nbGap = nbLbound
   Do
      nbGap = (3 * nbGap) + 1
   Loop Until nbGap > nbUbound
   
   Do
      nbGap = nbGap \ 3
      For i = nbGap + nbLbound To nbUbound
         Set DocPivot = vrArray( i )
         J = i - nbGap
         Do While (vrArray( J ).GetItemValue(Trim(Critere))(0) > DocPivot.GetItemValue(Trim(Critere))(0))
            Set vrArray( J + nbGap ) = vrArray( J )
            J = J - nbGap
            If J < nbLbound Then
               Exit Do
            End If   
         Loop
         Set vrArray( J + nbGap ) = DocPivot
      Next
   Loop Until nbGap = 1
   
   Set DocPivot = Nothing
   
   Exit Sub
ErreurHandle:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Exit Sub
End Sub

[/code]