VB6 的 IComparable 排序等效项

Question

有没有人遇到/创建过 VB6 中对象集合的通用排序的体面实现？

如果是这样，有人愿意提供代码或链接吗？

Answer 1

这对我来说很有效。

请注意，我不是作者。函数标题中提到了原始来源，但该网站现在似乎已经消失了。

让它运行的部分是 VB 鲜为人知或经常被忽视的 CallByName 命令。

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