This is a generic implementation of the infamous quick sort algorithm, which uses a simple callback mechanism allowing any data type inculding UDT's and objects to be sorted quickly and efficiently.
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination
As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal
lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As
Long, ByVal lParam As Long) As Long
'The data to be sorted must be in an array
'PointerToArrayOfElements should be a pointer to the element at which to
'begin sorting e.g. VarPtr(SortArray(i)) would begin sorting with the i'th
'element of SortArray
'ElementCount is the number of elements to sort
'ElementLength must be the physical size of an element in the array use LenB not
Len or better still
VarPtr(SortArray(1))-VarPtr(SortArray(0))
'CompareFunctionPointer must be a pointer to a compare function. The function
'must be declared in a standard bas module and must take 4
'parameters the first two should be declared byref as the type you are intending
'to sort the second 2 must be declared byval as long. The
'function must return a long which should be:
' 1 if the first element is greater than the
second
' 0 if first element is equal to second element
' -1 if first element is less than second element
Public Sub QuickSort(PointerToArrayOfElements As Long, ElementCount As Long, ElementLength
As Long, CompareFunctionPointer As Long)
Dim ElementPointers() As Long
Dim i As Long
Dim bytArray() As Byte
Dim lngOldElementPointers() As Long
ReDim ElementPointers(0 To ElementCount - 1)
ReDim lngOldElementPointers(0 To ElementCount - 1)
For i = 0 To ElementCount - 1
ElementPointers(i) = PointerToArrayOfElements + i * ElementLength
Next i
QSort ElementPointers, 0, ElementCount, CompareFunctionPointer, lngOldElementPointers
ReDim bytArray(0 To ElementLength * ElementCount - 1)
For i = 0 To ElementCount - 1
CopyMemory VarPtr(bytArray(i * ElementLength)), ElementPointers(i),
ElementLength
Next i
CopyMemory PointerToArrayOfElements, VarPtr(bytArray(0)), UBound(bytArray) + 1
End Sub
Private Sub QSort(lngElementPointers() As Long, Offset As Long, ElementCount As
Long, CompareFunctionPointer As Long, lngOldElementPointers() As Long)
Dim lngLessThanPosition As Long
Dim lngGreaterThanPosition As Long
Dim PivotIndex As Long
Dim i As Long
For i = 0 To ElementCount - 1
lngOldElementPointers(i) = lngElementPointers(Offset + i)
Next i
Select Case ElementCount
Case 1
'We only have one element so we don't need to do anything
Exit Sub
Case 2
If CallWindowProc(CompareFunctionPointer, lngOldElementPointers(0),
lngOldElementPointers(1), 0, 0) = 1 Then
'Swap them
lngElementPointers(Offset) = lngOldElementPointers(1)
lngElementPointers(Offset + 1) = lngOldElementPointers(0)
End If
Case Else
'We have 3 or more elements so subdivide and recurse
'Pick the element in the middle to be the pivot
PivotIndex = (ElementCount - 1) \ 2
'Refine this value
If CallWindowProc(CompareFunctionPointer, lngOldElementPointers(PivotIndex),
lngOldElementPointers(PivotIndex - 1), 0, 0) = 1 Then
'-1<0
If CallWindowProc(CompareFunctionPointer,
lngOldElementPointers(PivotIndex + 1), lngOldElementPointers(PivotIndex), 0, 0)
= 1 Then
'0<1
'-1,0,1
lngElementPointers(Offset)
= lngOldElementPointers(PivotIndex - 1)
lngElementPointers(Offset
+ ElementCount - 1) = lngOldElementPointers(PivotIndex + 1)
Else
'1<0
If CallWindowProc(CompareFunctionPointer,
lngOldElementPointers(PivotIndex + 1), lngOldElementPointers(PivotIndex - 1),
0, 0) = 1 Then
'-1<1
'-1,1,0
lngElementPointers(Offset)
= lngOldElementPointers(PivotIndex - 1)
lngElementPointers(Offset
+ ElementCount - 1) = lngOldElementPointers(PivotIndex)
lngOldElementPointers(PivotIndex)
= lngOldElementPointers(PivotIndex + 1)
Else
'1<-1
'1,-1,0
lngElementPointers(Offset)
= lngOldElementPointers(PivotIndex + 1)
lngElementPointers(Offset
+ ElementCount - 1) = lngOldElementPointers(PivotIndex)
lngOldElementPointers(PivotIndex)
= lngOldElementPointers(PivotIndex - 1)
End If
End If
Else
'0<-1
If CallWindowProc(CompareFunctionPointer,
lngOldElementPointers(PivotIndex), lngOldElementPointers(PivotIndex + 1), 0, 0)
= 1 Then
'1<0
'1,0,-1
lngElementPointers(Offset)
= lngOldElementPointers(PivotIndex + 1)
lngElementPointers(Offset
+ ElementCount - 1) = lngOldElementPointers(PivotIndex - 1)
Else
'0<1
If CallWindowProc(CompareFunctionPointer,
lngOldElementPointers(PivotIndex - 1), lngOldElementPointers(PivotIndex + 1),
0, 0) = 1 Then
'1<-1
'0,1,-1
lngElementPointers(Offset)
= lngOldElementPointers(PivotIndex)
lngElementPointers(Offset
+ ElementCount - 1) = lngOldElementPointers(PivotIndex - 1)
lngOldElementPointers(PivotIndex)
= lngOldElementPointers(PivotIndex + 1)
Else
'-1<1
'0,-1,1
lngElementPointers(Offset)
= lngOldElementPointers(PivotIndex)
lngElementPointers(Offset
+ ElementCount - 1) = lngOldElementPointers(PivotIndex + 1)
lngOldElementPointers(PivotIndex)
= lngOldElementPointers(PivotIndex - 1)
End If
End If
End If
If ElementCount = 3 Then
lngElementPointers(Offset + 1) = lngOldElementPointers(PivotIndex)
Exit Sub
End If
lngLessThanPosition = 1
lngGreaterThanPosition = ElementCount - 2
For i = 0 To PivotIndex - 2
If CallWindowProc(CompareFunctionPointer,
lngOldElementPointers(i), lngOldElementPointers(PivotIndex), 0, 0) = 1 Then
lngElementPointers(Offset
+ lngGreaterThanPosition) = lngOldElementPointers(i)
lngGreaterThanPosition
= lngGreaterThanPosition - 1
Else
lngElementPointers(Offset
+ lngLessThanPosition) = lngOldElementPointers(i)
lngLessThanPosition = lngLessThanPosition
+ 1
End If
Next i
For i = ElementCount - 1 To PivotIndex + 2 Step -1
If CallWindowProc(CompareFunctionPointer,
lngOldElementPointers(i), lngOldElementPointers(PivotIndex), 0, 0) = 1 Then
lngElementPointers(Offset
+ lngGreaterThanPosition) = lngOldElementPointers(i)
lngGreaterThanPosition
= lngGreaterThanPosition - 1
Else
lngElementPointers(Offset
+ lngLessThanPosition) = lngOldElementPointers(i)
lngLessThanPosition = lngLessThanPosition
+ 1
End If
Next i
Debug.Assert lngLessThanPosition = lngGreaterThanPosition
lngElementPointers(Offset + lngLessThanPosition) =
lngOldElementPointers(PivotIndex)
If lngLessThanPosition <> 0 Then
'Sort lower 'half'
QSort lngElementPointers, Offset, lngLessThanPosition,
CompareFunctionPointer, lngOldElementPointers
End If
'Sort upper 'half'
QSort lngElementPointers, Offset + lngLessThanPosition,
ElementCount - lngLessThanPosition, CompareFunctionPointer, lngOldElementPointers
End Select
End Sub
Comments