Listing 1: VBSort.wsc

<?XML version="1.0"?>
<?component debug="false" error="true"?>
<component>
<registration
  description="VBSort v1.0"
  progid="Penton.VBSort"
  classid="{5972716C-004D-4D15-90E9-61A039FD0043}"
  version="1.0"
/>
<public>
<property name="Descending" put/>
<property name="IgnoreCase" put/>
<property name="Random" put/>
<method name="Sort">
  <parameter name="ArrayName"/>
</method>
</public>
<script language="VBScript"><![CDATA[
Option Explicit
' BEGIN COMMENT
' Set the bit values for the SortFlags variable.
' END COMMENT
Const SORT_DEFAULT = 0
Const SORT_DESCENDING = 1
Const SORT_IGNORECASE = 2
Const SORT_RANDOM = 4

'BEGIN CALLOUT A 
' BEGIN COMMENT
' SortFlags is a bit array that controls the sort behavior. The
' CompareFunc variable contains a reference to the sort function.
' END COMMENT
Dim SortFlags, CompareFunc
'END CALLOUT A

' BEGIN COMMENT
' This subroutine sets or clears the SORT_DESCENDING bit.
' END COMMENT
Sub put_Descending(ByVal NewValue)
  If NewValue Then 
    SortFlags = SortFlags Or SORT_DESCENDING
  Else 
    SortFlags = SortFlags And (Not SORT_DESCENDING)
  End If
End Sub

' BEGIN COMMENT
' This subroutine sets or clears the SORT_IGNORECASE bit.
' END COMMENT
Sub put_IgnoreCase(ByVal NewValue)
  If NewValue Then
    SortFlags = SortFlags Or SORT_IGNORECASE
  Else
    SortFlags = SortFlags And (Not SORT_IGNORECASE)
  End If
End Sub

' BEGIN COMMENT
' This subroutine sets or clears the SORT_RANDOM bit.
' END COMMENT
Sub put_Random(ByVal NewValue)
  If NewValue Then
    SortFlags = SortFlags Or SORT_RANDOM
  Else
    SortFlags = SortFlags And (Not SORT_RANDOM)
  End If
End Sub

' BEGIN COMMENT
' The following sort comparison functions return these values:
' -1 if Item1 < Item2, 0 if Item1 = Item2, and 1 if Item1 > Item2.
' The functions use the StrComp function to improve
' performance if the items to be compared aren't numeric.

' This function sorts the array in ascending order (case sensitive).
' END COMMENT
Function SortDefault(ByVal Item1, ByVal Item2)
  If IsNumeric(Item1) And IsNumeric(Item2) Then
    SortDefault = (Item1 < Item2) - (Item2 < Item1)
  Else
    SortDefault = StrComp(Item1, Item2, vbBinaryCompare)
  End If
End Function

' BEGIN COMMENT
' This function sorts the array in descending order (case sensitive).
' END COMMENT
Function SortDescending(ByVal Item1, ByVal Item2)
  If IsNumeric(Item1) And IsNumeric(Item2) Then
    SortDescending = (Item1 > Item2) - (Item2 > Item1)
  Else
    SortDescending = StrComp(Item2, Item1, vbBinaryCompare)
  End If
End Function

' BEGIN COMMENT
' This function sorts the array in ascending order (ignores case).
' END COMMENT
Function SortIgnoreCase(ByVal Item1, ByVal Item2)
  If IsNumeric(Item1) And IsNumeric(Item2) Then
    SortIgnoreCase = (Item1 < Item2) - (Item2 < Item1)
  Else
    SortIgnoreCase = StrComp(Item1, Item2, vbTextCompare)
  End If
End Function

' BEGIN COMMENT
' This function sorts the array in descending order (ignores case).
' END COMMENT
Function SortDescendingIgnoreCase(ByVal Item1, ByVal Item2)
  If IsNumeric(Item1) And IsNumeric(Item2) Then
    SortDescendingIgnoreCase = (Item1 > Item2) - (Item2 > Item1)
  Else
    SortDescendingIgnoreCase = StrComp(Item2, Item1, vbTextCompare)
  End If
End Function

' BEGIN COMMENT
' This function randomly returns -1, 0, or 1.
' END COMMENT
Function SortRandom(ByVal Item1, ByVal Item2)
  SortRandom = Int((3 * Rnd()) - 1)
End Function

' BEGIN COMMENT
' This subroutine assigns the comparison function reference and sorts the array.
' END COMMENT
Sub Sort(ByRef ArrayName)
  Select Case SortFlags
    Case SORT_DESCENDING
      Set CompareFunc = GetRef("SortDescending")
    Case SORT_IGNORECASE
      Set CompareFunc = GetRef("SortIgnoreCase")
    Case SORT_DESCENDING Or SORT_IGNORECASE
      Set CompareFunc = GetRef("SortDescendingIgnoreCase")
    Case SORT_RANDOM
      Randomize  ' Initialize the random number generator. 
      Set CompareFunc = GetRef("SortRandom")
    Case Else
      Set CompareFunc = GetRef("SortDefault")
  End Select

'BEGIN CALLOUT B
  Quicksort ArrayName, 0, UBound(ArrayName)
'END CALLOUT B
End Sub

'BEGIN CALLOUT C
' BEGIN COMMENT
' This subroutine uses the Quicksort algorithm to sort the array in place.
' END COMMENT
Sub Quicksort(ByRef Arr, ByVal First, ByVal Last)
  Dim Low, High, MidVal, TempVal
  If First < Last Then
    Low = First
    High = Last
    MidVal = Arr((First + Last) \ 2)
    Do
      Do While (CompareFunc(Arr(Low), MidVal) < 0) And (Low < Last)
        Low = Low + 1
      Loop
      Do While (CompareFunc(Arr(High), MidVal) > 0) And (High > First)
        High = High - 1
      Loop
      If Low <= High Then
        TempVal = Arr(Low)
        Arr(Low) = Arr(High)
        Arr(High) = TempVal
        Low = Low + 1
        High = High - 1
      End If
    Loop While Low <= High
    If First < High Then Quicksort Arr, First, High
    If Low < Last Then Quicksort Arr, Low, Last
  End If
End Sub
'END CALLOUT C
]]></script>
</component>