Attribute VB_Name = "modSort"
Option Explicit
'
'
'=============================================================================================================
'
' modSort Module
' --------------
'
' Created By  : Kevin Wilson
'               http://www.TheVBZone.com   ( The VB Zone )
'               http://www.TheVBZone.net   ( The VB Zone .net )
'
' Created On  : June 23, 2003
' Last Update : June 23, 2003
'
' VB Versions : 5.0 / 6.0
'
' Requires    : NOTHING
'
' Description : This module is designed to make it easy to sort data arrays of different data types.  The
'               sort functions used in this module use an sorting algorithm called the "Shell Sort".  The
'               "Shell Sort" was invented by Donald Shell in 1959.  It is much more efficient than other
'               such O(n2) sort algorithms as the "Bubble Sort", "Selection Sort", and "Insertion Sort"
'               but still is fairly simplistic in it's design.  There other O(n log n) sorting methods
'               that are more efficient such as the "Heap Sort", "Merge Sort", and "Quick Sort"...
'               but these sorting algorithms are MUCH more complex and memory intensive.  They are also
'               oriented towards sorting numbers, not sorting strings.
'
' NOTE        : In my testing... I sorted both a string array and a number array containing 100,000 elements
'               each and both string arrays, and number arrays were sorted correctly within 5 to 10 seconds.
'
' See Also    : http://linux.wku.edu/~lamonml/algor/sort/index.html
'               http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnoffpro01/html/ABetterShellSortPartI.asp
'
' Example Use :
'
'   Option Explicit
'   Private Sub Form_Load()
'      Dim MyArray(4) As String
'      Dim bytCounter As Byte
'      MyArray(0) = "Hello"
'      MyArray(1) = "My"
'      MyArray(2) = "Name"
'      MyArray(3) = "Is"
'      MyArray(4) = "Kevin"
'      Call Sort_STRING(MyArray, True)
'      Me.AutoRedraw = True
'      For bytCounter = 0 To 4
'         Me.Print MyArray(bytCounter)
'      Next
'   End Sub
'
'=============================================================================================================
'
' LEGAL:
'
' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit
' given where credit is due.  Also, it is not required, but it would be appreciated if you would mention
' somewhere in your compiled program that that your program makes use of code written and distributed by
' Kevin Wilson (www.TheVBZone.com).  Feel free to link to this code via your web site or articles.
'
' You may NOT take this code and pass it off as your own.  You may NOT distribute this code on your own server
' or web site.  You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products,
' utilities, or applications that directly compete with products, utilities, and applications created by Kevin
' Wilson, TheVBZone.com, or Wilson Media.  You may NOT take this code and sell it for profit without first
' obtaining the written consent of the author Kevin Wilson.
'
' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without
' warning or notice.  Copyrightİ by Kevin Wilson.  All rights reserved.
'
'=============================================================================================================




'=============================================================================================================
' Sort_* Functions
'
' The Sort_BYTE, Sort_INTEGER, Sort_LONG, Sort_SINGLE, Sort_DOUBLE, Sort_DATE, and Sort_STRING functions take
' in the respective data type arrays and sort them either ascending or decending depending on the parameters
' passed to the functions.
'
' Parameter:                 Use:
' -------------------------------------------
' strArray()                 References the array to be sorted.
' blnDecending               If FALSE (default), the array will be sorted in ascending order (A,B,C).  If
'                            TRUE, the array will be sorted in descending order (Z,X,Y).
'
' Return:
' -------
' (none)
'
'=============================================================================================================
Public Sub Sort_STRING(ByRef strArray() As String, Optional ByVal blnDecending As Boolean = False)
   
   Dim strTempVal  As String
   Dim lngCounter  As Long
   Dim lngGapSize  As Long
   Dim lngCurPos   As Long
   Dim lngFirstRow As Long
   Dim lngLastRow  As Long
   Dim lngNumRows  As Long
   
   lngFirstRow = LBound(strArray)
   lngLastRow = UBound(strArray)
   lngNumRows = lngLastRow - lngFirstRow + 1
   
   Do
      lngGapSize = lngGapSize * 3 + 1
   Loop Until lngGapSize > lngNumRows
   
   Do
      lngGapSize = lngGapSize \ 3
      For lngCounter = (lngGapSize + lngFirstRow) To lngLastRow
         lngCurPos = lngCounter
         strTempVal = strArray(lngCounter)
         Do While CompareResult_TXT(strArray(lngCurPos - lngGapSize), strTempVal, blnDecending)
            strArray(lngCurPos) = strArray(lngCurPos - lngGapSize)
            lngCurPos = lngCurPos - lngGapSize
            If (lngCurPos - lngGapSize) < lngFirstRow Then Exit Do
         Loop
         strArray(lngCurPos) = strTempVal
      Next
   Loop Until lngGapSize = 1
   
End Sub

' (See documentation for the "Sort_STRING" function)
Public Sub Sort_BYTE(ByRef bytArray() As Byte, Optional ByVal blnDecending As Boolean = False)
   
   Dim strTempVal  As String
   Dim lngCounter  As Long
   Dim lngGapSize  As Long
   Dim lngCurPos   As Long
   Dim lngFirstRow As Long
   Dim lngLastRow  As Long
   Dim lngNumRows  As Long
   
   lngFirstRow = LBound(bytArray)
   lngLastRow = UBound(bytArray)
   lngNumRows = lngLastRow - lngFirstRow + 1
   
   Do
      lngGapSize = lngGapSize * 3 + 1
   Loop Until lngGapSize > lngNumRows
   
   Do
      lngGapSize = lngGapSize \ 3
      For lngCounter = (lngGapSize + lngFirstRow) To lngLastRow
         lngCurPos = lngCounter
         strTempVal = bytArray(lngCounter)
         Do While CompareResult_NUM(bytArray(lngCurPos - lngGapSize), strTempVal, blnDecending)
            bytArray(lngCurPos) = bytArray(lngCurPos - lngGapSize)
            lngCurPos = lngCurPos - lngGapSize
            If (lngCurPos - lngGapSize) < lngFirstRow Then Exit Do
         Loop
         bytArray(lngCurPos) = strTempVal
      Next
   Loop Until lngGapSize = 1
   
End Sub

' (See documentation for the "Sort_STRING" function)
Public Sub Sort_INTEGER(ByRef intArray() As Integer, Optional ByVal blnDecending As Boolean = False)
   
   Dim strTempVal  As String
   Dim lngCounter  As Long
   Dim lngGapSize  As Long
   Dim lngCurPos   As Long
   Dim lngFirstRow As Long
   Dim lngLastRow  As Long
   Dim lngNumRows  As Long
   
   lngFirstRow = LBound(intArray)
   lngLastRow = UBound(intArray)
   lngNumRows = lngLastRow - lngFirstRow + 1
   
   Do
      lngGapSize = lngGapSize * 3 + 1
   Loop Until lngGapSize > lngNumRows
   
   Do
      lngGapSize = lngGapSize \ 3
      For lngCounter = (lngGapSize + lngFirstRow) To lngLastRow
         lngCurPos = lngCounter
         strTempVal = intArray(lngCounter)
         Do While CompareResult_NUM(intArray(lngCurPos - lngGapSize), strTempVal, blnDecending)
            intArray(lngCurPos) = intArray(lngCurPos - lngGapSize)
            lngCurPos = lngCurPos - lngGapSize
            If (lngCurPos - lngGapSize) < lngFirstRow Then Exit Do
         Loop
         intArray(lngCurPos) = strTempVal
      Next
   Loop Until lngGapSize = 1
   
End Sub

' (See documentation for the "Sort_STRING" function)
Public Sub Sort_LONG(ByRef lngArray() As Long, Optional ByVal blnDecending As Boolean = False)
   
   Dim strTempVal  As String
   Dim lngCounter  As Long
   Dim lngGapSize  As Long
   Dim lngCurPos   As Long
   Dim lngFirstRow As Long
   Dim lngLastRow  As Long
   Dim lngNumRows  As Long
   
   lngFirstRow = LBound(lngArray)
   lngLastRow = UBound(lngArray)
   lngNumRows = lngLastRow - lngFirstRow + 1
   
   Do
      lngGapSize = lngGapSize * 3 + 1
   Loop Until lngGapSize > lngNumRows
   
   Do
      lngGapSize = lngGapSize \ 3
      For lngCounter = (lngGapSize + lngFirstRow) To lngLastRow
         lngCurPos = lngCounter
         strTempVal = lngArray(lngCounter)
         Do While CompareResult_NUM(lngArray(lngCurPos - lngGapSize), strTempVal, blnDecending)
            lngArray(lngCurPos) = lngArray(lngCurPos - lngGapSize)
            lngCurPos = lngCurPos - lngGapSize
            If (lngCurPos - lngGapSize) < lngFirstRow Then Exit Do
         Loop
         lngArray(lngCurPos) = strTempVal
      Next
   Loop Until lngGapSize = 1
   
End Sub

' (See documentation for the "Sort_STRING" function)
Public Sub Sort_SINGLE(ByRef sngArray() As Single, Optional ByVal blnDecending As Boolean = False)
   
   Dim strTempVal  As String
   Dim lngCounter  As Long
   Dim lngGapSize  As Long
   Dim lngCurPos   As Long
   Dim lngFirstRow As Long
   Dim lngLastRow  As Long
   Dim lngNumRows  As Long
   
   lngFirstRow = LBound(sngArray)
   lngLastRow = UBound(sngArray)
   lngNumRows = lngLastRow - lngFirstRow + 1
   
   Do
      lngGapSize = lngGapSize * 3 + 1
   Loop Until lngGapSize > lngNumRows
   
   Do
      lngGapSize = lngGapSize \ 3
      For lngCounter = (lngGapSize + lngFirstRow) To lngLastRow
         lngCurPos = lngCounter
         strTempVal = sngArray(lngCounter)
         Do While CompareResult_NUM(sngArray(lngCurPos - lngGapSize), strTempVal, blnDecending)
            sngArray(lngCurPos) = sngArray(lngCurPos - lngGapSize)
            lngCurPos = lngCurPos - lngGapSize
            If (lngCurPos - lngGapSize) < lngFirstRow Then Exit Do
         Loop
         sngArray(lngCurPos) = strTempVal
      Next
   Loop Until lngGapSize = 1
   
End Sub

' (See documentation for the "Sort_STRING" function)
Public Sub Sort_DOUBLE(ByRef dblArray() As Double, Optional ByVal blnDecending As Boolean = False)
   
   Dim strTempVal  As String
   Dim lngCounter  As Long
   Dim lngGapSize  As Long
   Dim lngCurPos   As Long
   Dim lngFirstRow As Long
   Dim lngLastRow  As Long
   Dim lngNumRows  As Long
   
   lngFirstRow = LBound(dblArray)
   lngLastRow = UBound(dblArray)
   lngNumRows = lngLastRow - lngFirstRow + 1
   
   Do
      lngGapSize = lngGapSize * 3 + 1
   Loop Until lngGapSize > lngNumRows
   
   Do
      lngGapSize = lngGapSize \ 3
      For lngCounter = (lngGapSize + lngFirstRow) To lngLastRow
         lngCurPos = lngCounter
         strTempVal = dblArray(lngCounter)
         Do While CompareResult_NUM(dblArray(lngCurPos - lngGapSize), strTempVal, blnDecending)
            dblArray(lngCurPos) = dblArray(lngCurPos - lngGapSize)
            lngCurPos = lngCurPos - lngGapSize
            If (lngCurPos - lngGapSize) < lngFirstRow Then Exit Do
         Loop
         dblArray(lngCurPos) = strTempVal
      Next
   Loop Until lngGapSize = 1
   
End Sub

' (See documentation for the "Sort_STRING" function)
Public Sub Sort_DATE(ByRef datArray() As Double, Optional ByVal blnDecending As Boolean = False)
   
   Dim strTempVal  As String
   Dim lngCounter  As Long
   Dim lngGapSize  As Long
   Dim lngCurPos   As Long
   Dim lngFirstRow As Long
   Dim lngLastRow  As Long
   Dim lngNumRows  As Long
   
   lngFirstRow = LBound(datArray)
   lngLastRow = UBound(datArray)
   lngNumRows = lngLastRow - lngFirstRow + 1
   
   Do
      lngGapSize = lngGapSize * 3 + 1
   Loop Until lngGapSize > lngNumRows
   
   Do
      lngGapSize = lngGapSize \ 3
      For lngCounter = (lngGapSize + lngFirstRow) To lngLastRow
         lngCurPos = lngCounter
         strTempVal = datArray(lngCounter)
         Do While CompareResult_DAT(datArray(lngCurPos - lngGapSize), strTempVal, blnDecending)
            datArray(lngCurPos) = datArray(lngCurPos - lngGapSize)
            lngCurPos = lngCurPos - lngGapSize
            If (lngCurPos - lngGapSize) < lngFirstRow Then Exit Do
         Loop
         datArray(lngCurPos) = strTempVal
      Next
   Loop Until lngGapSize = 1
   
End Sub


'_____________________________________________________________________________________________________________
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ


' This function is used within this module only to compare values
Private Function CompareResult_TXT(ByVal strValue1 As String, ByVal strValue2 As String, Optional blnDescending As Boolean = False) As Boolean
   CompareResult_TXT = CBool(StrComp(strValue1, strValue2, vbTextCompare) = 1)
   CompareResult_TXT = CompareResult_TXT Xor blnDescending
End Function

' This function is used within this module only to compare values
Private Function CompareResult_NUM(ByVal dblValue1 As Double, ByVal dblValue2 As Double, Optional blnDescending As Boolean = False) As Boolean
   CompareResult_NUM = CBool(dblValue1 > dblValue2)
   CompareResult_NUM = CompareResult_NUM Xor blnDescending
End Function

' This function is used within this module only to compare values
Private Function CompareResult_DAT(ByVal datValue1 As Date, ByVal datValue2 As Date, Optional blnDescending As Boolean = False) As Boolean
   CompareResult_DAT = CBool(datValue1 > datValue2)
   CompareResult_DAT = CompareResult_DAT Xor blnDescending
End Function