Attribute VB_Name = "MerriSort"
' MerriSort.bas - speed optimized median three QuickSort
' array types supported: Boolean, Byte, Currency, Date, Double, Integer, Long, Single, String
'
' Boolean, Byte & Integer sorted using CountSort (faster for large arrays)
' Date & Double sorted using QuickSort with Double datatype
'
' usage: QSort Not Not YourArrayVariable
Option Explicit

Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)

Private Type StrArrType
    S() As String
End Type

' for comparison: original Variant version by Ellis Dee @ http://www.vbforums.com/showpost.php?p=2909260&postcount=14
Public Sub MedianThreeQuickSort1(ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Variant
    Dim lngIndex As Long
    Dim varSwap As Variant
    Dim A As Long
    Dim B As Long
    Dim C As Long
    
    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    lngIndex = plngRight - plngLeft + 1
    A = Int(lngIndex * Rnd) + plngLeft
    B = Int(lngIndex * Rnd) + plngLeft
    C = Int(lngIndex * Rnd) + plngLeft
    If pvarArray(A) <= pvarArray(B) And pvarArray(B) <= pvarArray(C) Then
        lngIndex = B
    Else
        If pvarArray(B) <= pvarArray(A) And pvarArray(A) <= pvarArray(C) Then
            lngIndex = A
        Else
            lngIndex = C
        End If
    End If
    varMid = pvarArray(lngIndex)
    Do
        Do While pvarArray(lngFirst) < varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        Do While varMid < pvarArray(lngLast) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        If lngFirst <= lngLast Then
            varSwap = pvarArray(lngFirst)
            pvarArray(lngFirst) = pvarArray(lngLast)
            pvarArray(lngLast) = varSwap
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If lngLast - plngLeft < plngRight - lngFirst Then
        If plngLeft < lngLast Then MedianThreeQuickSort1 pvarArray, plngLeft, lngLast
        If lngFirst < plngRight Then MedianThreeQuickSort1 pvarArray, lngFirst, plngRight
    Else
        If lngFirst < plngRight Then MedianThreeQuickSort1 pvarArray, lngFirst, plngRight
        If plngLeft < lngLast Then MedianThreeQuickSort1 pvarArray, plngLeft, lngLast
    End If
End Sub

Public Sub QSort(ByVal NotNotArray As Long)
    Dim A() As Long, AH(0 To 5) As Long, AP As Long
    Dim ArrayBase As Long, H As Long, J As Long, K As Long, R As Long
    ' VB6 IDE bug with Not ArrayName, this fixes it
    Debug.Assert App.hInstance
    ' did we get any pointer?
    If NotNotArray Then
        ' is the pointer negative or positive?
        If NotNotArray < 0 Then R = -4 Else R = 4
        ' yippee, now lets check it out
        AH(0) = 1: AH(1) = 4: AH(3) = NotNotArray - R: AH(4) = &H3FFFFFFF
        ' start safe array hack using the header created in above line
        AP = ArrPtr(A): PutMem4 AP, VarPtr(AH(0))
        ' first of all: we must have datatype defined and the array must be one dimensional
        If (A(1) And &H80FFFF) = &H800001 Then
            ' does it have any items?
            If A(5) > 0 Then
                ' remember old base & force zero base!
                ArrayBase = A(6): A(6) = 0
                ' check out the datatype!
                Select Case A(0)
                Case vbBoolean, vbInteger
                    ' count sort is the fastest here!
                    Dim I() As Integer, IC As Integer, ICount(&H8000 To &H7FFF) As Long
                    ' get I variable pointer and position our array at it
                    AH(3) = ArrPtr(I): A(0) = NotNotArray
                    ' start counting!
                    For H = 0 To UBound(I)
                        ' get byte value
                        IC = I(H)
                        ' increase counter for that value
                        ICount(IC) = ICount(IC) + 1
                    Next H
                    ' now loop through and change things
                    For H = &H8000 To &H7FFF
                        ' we cannot use a Integer in the loop so convert long to byte
                        IC = H
                        ' now loop through the count to zero
                        For J = ICount(H) To 1 Step -1
                            ' change to the current byte
                            I(K) = IC
                            ' increase kounter
                            K = K + 1
                        Next J
                    Next H
                    ' release I from the safe array header
                    A(0) = 0
                Case vbByte
                    ' count sort is the fastest here!
                    Dim B() As Byte, BC As Byte, BCount(0 To 255) As Long
                    ' get B variable pointer and position our array at it
                    AH(3) = ArrPtr(B): A(0) = NotNotArray
                    ' start counting!
                    For H = 0 To UBound(B)
                        ' get byte value
                        BC = B(H)
                        ' increase counter for that value
                        BCount(BC) = BCount(BC) + 1
                    Next H
                    ' now loop through and change things
                    For H = 0 To 255
                        ' we cannot use a Byte in the loop so convert long to byte
                        BC = H
                        ' now loop through the count to zero
                        For J = BCount(H) To 1 Step -1
                            ' change to the current byte
                            B(K) = BC
                            ' increase kounter
                            K = K + 1
                        Next J
                    Next H
                    ' release B from the safe array header
                    A(0) = 0
                Case vbCurrency
                    Dim C() As Currency
                    ' get C variable pointer and place safe array header there
                    AH(3) = ArrPtr(C): A(0) = NotNotArray
                    ' do the sort
                    QSortCurrency C, 0, UBound(C), Rnd, Rnd, Rnd
                    ' release C from the safe array header
                    A(0) = 0
                Case vbDate, vbDouble
                    Dim D() As Double
                    ' get D variable pointer and place safe array header there
                    AH(3) = ArrPtr(D): A(0) = NotNotArray
                    ' do the sort
                    QSortDouble D, 0, UBound(D), Rnd, Rnd, Rnd
                    ' release D from the safe array header
                    A(0) = 0
                Case vbLong
                    Dim L() As Long
                    ' get L variable pointer and place safe array header there
                    AH(3) = ArrPtr(L): A(0) = NotNotArray
                    ' do the sort
                    QSortLong L, 0, UBound(L), Rnd, Rnd, Rnd
                    ' release L from the safe array header
                    A(0) = 0
                Case vbSingle
                    Dim S() As Single
                    ' get S variable pointer and place safe array header there
                    AH(3) = ArrPtr(S): A(0) = NotNotArray
                    ' do the sort
                    QSortSingle S, 0, UBound(S), Rnd, Rnd, Rnd
                    ' release S from the safe array header
                    A(0) = 0
                Case vbString
                    ' we cannot use ArrPtr on a string array, so... use UDT to trick our way out of it!
                    Dim StrArr As StrArrType, SP As Long
                    ' get variable pointer and place safe array header there
                    SP = VarPtr(StrArr): AH(3) = SP: A(0) = NotNotArray
                    ' then get the pointer so that A points to the same data StrArr.S points to
                    AH(3) = NotNotArray: AH(3) = A(3)
                    ' do the sort
                    QSortString StrArr.S, A, 0, UBound(StrArr.S), Rnd, Rnd, Rnd
                    ' release StrPtr.S from safe array header
                    AH(3) = SP: A(0) = 0
                Case Else
                    ' restore everything & cleanup!
                    AH(3) = NotNotArray - R
                    A(6) = ArrayBase
                    AH(3) = AP: A(0) = 0
                    ' now raise an error...
                    Err.Raise 5, "MerriSort.QSort", "Invalid array datatype (must be Boolean, Byte, Currency, Date, Double, Integer, Long, Single or String)"
                    ' in case somebody uses error trapping
                    Exit Sub
                End Select
                ' restore original base
                AH(3) = NotNotArray - R
                A(6) = ArrayBase
            End If
        End If
        ' end safe array hack
        AH(3) = AP: A(0) = 0
    End If
End Sub

Private Sub QSortCurrency(Arr() As Currency, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double)
    Dim Index As Long, First As Long, Last As Long, Middle As Currency, Swap As Currency
    Dim A As Long, B As Long, C As Long
    First = Left
    Last = Right
    Index = Right - Left + 1
    A = CLng(Int(RndA * Index)) + Left
    B = CLng(Int(RndB * Index)) + Left
    C = CLng(Int(RndC * Index)) + Left
    If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then
        Index = B
    Else
        If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then
            Index = A
        Else
            Index = C
        End If
    End If
    Middle = Arr(Index)
    Do
        Do While Arr(First) < Middle And First < Right
            First = First + 1
        Loop
        Do While Middle < Arr(Last) And Last > Left
            Last = Last - 1
        Loop
        If First <= Last Then
            Swap = Arr(First)
            Arr(First) = Arr(Last)
            Arr(Last) = Swap
            First = First + 1
            Last = Last - 1
        End If
    Loop Until First > Last
    If Last - Left < Right - First Then
        If Left < Last Then QSortCurrency Arr, Left, Last, RndA, RndB, RndC
        If First < Right Then QSortCurrency Arr, First, Right, RndA, RndB, RndC
    Else
        If First < Right Then QSortCurrency Arr, First, Right, RndA, RndB, RndC
        If Left < Last Then QSortCurrency Arr, Left, Last, RndA, RndB, RndC
    End If
End Sub

Private Sub QSortDouble(Arr() As Double, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double)
    Dim Index As Long, First As Long, Last As Long, Middle As Double, Swap As Double
    Dim A As Long, B As Long, C As Long
    First = Left
    Last = Right
    Index = Right - Left + 1
    A = CLng(Int(RndA * Index)) + Left
    B = CLng(Int(RndB * Index)) + Left
    C = CLng(Int(RndC * Index)) + Left
    If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then
        Index = B
    Else
        If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then
            Index = A
        Else
            Index = C
        End If
    End If
    Middle = Arr(Index)
    Do
        Do While Arr(First) < Middle And First < Right
            First = First + 1
        Loop
        Do While Middle < Arr(Last) And Last > Left
            Last = Last - 1
        Loop
        If First <= Last Then
            Swap = Arr(First)
            Arr(First) = Arr(Last)
            Arr(Last) = Swap
            First = First + 1
            Last = Last - 1
        End If
    Loop Until First > Last
    If Last - Left < Right - First Then
        If Left < Last Then QSortDouble Arr, Left, Last, RndA, RndB, RndC
        If First < Right Then QSortDouble Arr, First, Right, RndA, RndB, RndC
    Else
        If First < Right Then QSortDouble Arr, First, Right, RndA, RndB, RndC
        If Left < Last Then QSortDouble Arr, Left, Last, RndA, RndB, RndC
    End If
End Sub

Private Sub QSortLong(Arr() As Long, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double)
    Dim Index As Long, First As Long, Last As Long, Middle As Long, Swap As Long
    Dim A As Long, B As Long, C As Long
    First = Left
    Last = Right
    Index = Right - Left + 1
    A = CLng(Int(RndA * Index)) + Left
    B = CLng(Int(RndB * Index)) + Left
    C = CLng(Int(RndC * Index)) + Left
    If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then
        Index = B
    Else
        If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then
            Index = A
        Else
            Index = C
        End If
    End If
    Middle = Arr(Index)
    Do
        Do While Arr(First) < Middle And First < Right
            First = First + 1
        Loop
        Do While Middle < Arr(Last) And Last > Left
            Last = Last - 1
        Loop
        If First <= Last Then
            Swap = Arr(First)
            Arr(First) = Arr(Last)
            Arr(Last) = Swap
            First = First + 1
            Last = Last - 1
        End If
    Loop Until First > Last
    If Last - Left < Right - First Then
        If Left < Last Then QSortLong Arr, Left, Last, RndA, RndB, RndC
        If First < Right Then QSortLong Arr, First, Right, RndA, RndB, RndC
    Else
        If First < Right Then QSortLong Arr, First, Right, RndA, RndB, RndC
        If Left < Last Then QSortLong Arr, Left, Last, RndA, RndB, RndC
    End If
End Sub

Private Sub QSortSingle(Arr() As Single, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double)
    Dim Index As Long, First As Long, Last As Long, Middle As Single, Swap As Single
    Dim A As Long, B As Long, C As Long
    First = Left
    Last = Right
    Index = Right - Left + 1
    A = CLng(Int(RndA * Index)) + Left
    B = CLng(Int(RndB * Index)) + Left
    C = CLng(Int(RndC * Index)) + Left
    If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then
        Index = B
    Else
        If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then
            Index = A
        Else
            Index = C
        End If
    End If
    Middle = Arr(Index)
    Do
        Do While Arr(First) < Middle And First < Right
            First = First + 1
        Loop
        Do While Middle < Arr(Last) And Last > Left
            Last = Last - 1
        Loop
        If First <= Last Then
            Swap = Arr(First)
            Arr(First) = Arr(Last)
            Arr(Last) = Swap
            First = First + 1
            Last = Last - 1
        End If
    Loop Until First > Last
    If Last - Left < Right - First Then
        If Left < Last Then QSortSingle Arr, Left, Last, RndA, RndB, RndC
        If First < Right Then QSortSingle Arr, First, Right, RndA, RndB, RndC
    Else
        If First < Right Then QSortSingle Arr, First, Right, RndA, RndB, RndC
        If Left < Last Then QSortSingle Arr, Left, Last, RndA, RndB, RndC
    End If
End Sub

Private Sub QSortString(Arr() As String, ArrL() As Long, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double)
    Dim Index As Long, First As Long, Last As Long, Middle As String, Swap As Long
    Dim A As Long, B As Long, C As Long
    First = Left
    Last = Right
    Index = Right - Left + 1
    A = CLng(Int(RndA * Index)) + Left
    B = CLng(Int(RndB * Index)) + Left
    C = CLng(Int(RndC * Index)) + Left
    If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then
        Index = B
    Else
        If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then
            Index = A
        Else
            Index = C
        End If
    End If
    Middle = Arr(Index)
    Do
        Do While Arr(First) < Middle And First < Right
            First = First + 1
        Loop
        Do While Middle < Arr(Last) And Last > Left
            Last = Last - 1
        Loop
        If First <= Last Then
            Swap = ArrL(First)
            ArrL(First) = ArrL(Last)
            ArrL(Last) = Swap
            First = First + 1
            Last = Last - 1
        End If
    Loop Until First > Last
    If Last - Left < Right - First Then
        If Left < Last Then QSortString Arr, ArrL, Left, Last, RndA, RndB, RndC
        If First < Right Then QSortString Arr, ArrL, First, Right, RndA, RndB, RndC
    Else
        If First < Right Then QSortString Arr, ArrL, First, Right, RndA, RndB, RndC
        If Left < Last Then QSortString Arr, ArrL, Left, Last, RndA, RndB, RndC
    End If
End Sub