Блог

Кто-нибудь сталкивался / создал достойную реализацию универсальной сортировки коллекций объектов в VB6?

Если да, кто-нибудь хочет предоставить код или ссылку?

Это делает трюк для меня.

Пожалуйста, обратите внимание, что я не являюсь автором. Исходный источник упоминается в заголовке функции, но этот сайт, похоже, к настоящему времени исчез.

Часть, позволяющая запустить это, — это малоизвестная или часто упускаемая из виду CallByName команда VB.

 Public Function SortItemCollection(col As Collection, ByVal sPropertyName As String, _
   ByVal bolSortAscending As Boolean, ByVal bolCompareNumeric As Boolean) As Collection
'------------------------------------------------------------------------------
'Purpose  : Sort a collection of objects using one of the object's properties
'           as the sorting field. That property must be of a primitive
'           data type (string or numeric)
'
'Prereq.  : !!! Important !!! The scope of property sPropertyName needs to be
'           declared as Public.
'Parameter: -
'Returns  : -
'Note     : The idea is to have a class that is added to a collection object.
'           Pass that collection to this function below and the property name
'           is the “field” within the class that is to be sorted on.
'
'   Author: Original author unknown, refined by Branko Pedisic
'   Source: http://www.ifnottruethenfalse.com/sort-a-collection-object-in-vb6/
'  Changed: 19.03.2014
'           - Source reformatted and variable names changed to accommodate my
'           naming conventions.
'------------------------------------------------------------------------------
   Dim colNew As Collection
   Dim oCurrent As Object
   Dim oCompare As Object
   Dim lCompareIndex As Long
   Dim sCurrent As String
   Dim sCompare As String
   Dim bolGreaterValueFound As Boolean

   'make a copy of the collection, ripping through it one item
   'at a time, adding to new collection in right order...

   Set colNew = New Collection

   For Each oCurrent In col

      'get value of current item...
      sCurrent = CallByName(oCurrent, sPropertyName, VbGet)

      'setup for compare loop
      bolGreaterValueFound = False
      lCompareIndex = 0

      For Each oCompare In colNew
         lCompareIndex = lCompareIndex   1

         sCompare = CallByName(oCompare, sPropertyName, VbGet)

         'optimization - instead of doing this for every iteration,
         'have 2 different loops...
         If bolCompareNumeric = True Then
            'this means we are looking for a numeric sort order...

            If (bolSortAscending = True) Then
               If Val(sCurrent) < Val(sCompare) Then
                  'found an item in compare collection that is greater...
                  'add it to the new collection...
                  bolGreaterValueFound = True
                  colNew.Add oCurrent, , lCompareIndex
                  Exit For
               End If
            Else
               If Val(sCurrent) > Val(sCompare) Then
                  'found an item in compare collection that is greater...
                  'add it to the new collection...
                  bolGreaterValueFound = True
                  colNew.Add oCurrent, , lCompareIndex
                  Exit For
               End If
            End If

         Else     '// If bolCompareNumeric = True
            'this means we are looking for a string sort...

            If (bolSortAscending = True) Then
               If sCurrent < sCompare Then
                  'found an item in compare collection that is greater...
                  'add it to the new collection...
                  bolGreaterValueFound = True
                  colNew.Add oCurrent, , lCompareIndex
                  Exit For
               End If
            Else
               If sCurrent > sCompare Then
                  'found an item in compare collection that is greater...
                  'add it to the new collection...
                  bolGreaterValueFound = True
                  colNew.Add oCurrent, , lCompareIndex
                  Exit For
               End If
            End If

         End If   '// If bolCompareNumeric = True
      Next oCompare

      'if we didn't find something bigger, just add it to the end of
      'the new collection...
      If bolGreaterValueFound = False Then
         colNew.Add oCurrent
      End If

   Next oCurrent

   'return the new collection...
   Set SortItemCollection = colNew
   Set colNew = Nothing

End Function