VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 1  'NoTransaction
END
Attribute VB_Name = "QuickSortDIctionary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
' Object oriented quicksort in vb

'Using variants to be compatible with asp
'Enables us to sort just about anything

'Main Routine:
'SortDictionary
'Input: Scripting.Dictionary to be sorted, containing Objects implementing a "Compare" method
'Output: Array containing the keys sorted in order of the Compare method of the objects

'The Compare method should return -1, 1 or 0

'(The keys are not sorted alphanumerically)

'Loop over the output array, and retrieve one key at a time to present the
'dictionary objects in sorted order.

'For example usage, see the TestSortableObject Class.

Option Explicit

Dim objDictionary As Variant
Dim varCompareArgument As Variant ' Argument
Dim blnSortOrder As Boolean 'True = Asc, False = Desc
Public Function SortDictionary(ByRef objDictionaryIn As Variant, ByRef varCompareArgumentIn As Variant, Optional ByVal blnSortOrderIn As Boolean = True) As Variant
    Dim varArray() As Variant
    blnSortOrder = blnSortOrderIn
    If IsObject(varCompareArgumentIn) Then
        Set varCompareArgument = varCompareArgumentIn
    Else
        varCompareArgument = varCompareArgumentIn
    End If
    Set objDictionary = objDictionaryIn
    varArray = objDictionary.Keys
    sQsort varArray, LBound(varArray), UBound(varArray)
    SortDictionary = varArray
End Function


Private Sub sQsort(ByRef varArray() As Variant, ByVal lngStart As Long, ByVal lngEnd As Long)
    Dim lngP As Long
    If lngEnd > lngStart Then
        lngP = fPartition(varArray, lngStart, lngEnd)
        sQsort varArray, lngStart, lngP - 1
        sQsort varArray, lngP + 1, lngEnd
    End If
End Sub

Private Function fCompare(ByRef a As Variant, ByRef b As Variant)
    If blnSortOrder Then
        fCompare = objDictionary.Item(a).Compare(objDictionary.Item(b), varCompareArgument)
    Else
        fCompare = objDictionary.Item(b).Compare(objDictionary.Item(a), varCompareArgument)
    End If
End Function

Private Function fPartition(ByRef varArray() As Variant, ByVal lngStart As Long, ByVal lngEnd As Long) As Long
    Dim lngLeft As Long, lngRight As Long
    Dim varPartitionElement As Variant
    
    'Arbitrary partition start, better ways exists...
    If IsObject(varArray(lngEnd)) Then
        Set varPartitionElement = varArray(lngEnd)
    Else
        varPartitionElement = varArray(lngEnd)
    End If
    
    lngLeft = lngStart - 1
    lngRight = lngEnd
    
    Do While True
        Do While fCompare(varPartitionElement, varArray(lngLeft + 1)) = 1
            lngLeft = lngLeft + 1
            If lngLeft = lngEnd Then Exit Do
        Loop
        lngLeft = lngLeft + 1
        Do While fCompare(varPartitionElement, varArray(lngRight - 1)) = -1
            lngRight = lngRight - 1
            If lngRight = lngStart Then Exit Do
        Loop
        lngRight = lngRight - 1
        If lngLeft >= lngRight Then Exit Do
        sSwap varArray, lngLeft, lngRight
    Loop
    sSwap varArray, lngLeft, lngEnd
    fPartition = lngLeft
End Function

Private Sub sSwap(ByRef varArray() As Variant, ByVal lngi As Long, ByVal lngj As Long)
    Dim varTmp As Variant
    If IsObject(varArray(lngi)) Then
        Set varTmp = varArray(lngi)
        Set varArray(lngi) = varArray(lngj)
        Set varArray(lngj) = varTmp
    Else
        varTmp = varArray(lngi)
        varArray(lngi) = varArray(lngj)
        varArray(lngj) = varTmp
    End If
End Sub

