Sorting Timer

in Visual Basic®

by Rick Meyer       Home



Running the Timer



Other Sorting Pages
Sorting Viewer
Simple Ascend Sorting
Simple Descend Sorting
Simple Bi-Direction Sorting

Note: You can skip the following instructions and Download the Project (7K).
   To Build the Project

1. Start a new standard exe.
2. On Form1 put a Label named Label1.
3. Set the Label1.Index property to 0.
4. On Form1 put a CommandButton named Command1.
5. Set the Command1.Index property to 0.
6. On Form1 put a TextBox named Text1.

   There is no need to position or size the above controls
   on the form since that is all done in the Form_Load.

Now you are ready for the code. Select all of the following code (by clicking on the word 'Option' three times) and copy it to the clipboard [Ctrl][Insert]. Then paste it into the code window of Form1 with [Shift][Insert]. Variable Key
% As Integer
& As Long
! As Single
# As Double
$ As String 
Option Explicit

'=======================================================
'      Declarations for the Timing API Call
'=======================================================
Const TIME_MS = 1

Private Type SMPTE
    hour As Byte
    min As Byte
    sec As Byte
    frame As Byte
    fps As Byte
    dummy As Byte
    pad(2) As Byte
End Type
Private Type MMTIME
    wType As Long
    units As Long
    smpteVal As SMPTE
    songPtrPos As Long
End Type

Private Declare Function timeGetSystemTime& _
    Lib "winmm.dll" (lpTime As MMTIME, ByVal uSize&)

Dim mmt As MMTIME, L1&

'=======================================================
'          Other Form Level Declarations
'=======================================================
Const BUTTONS% = 4
Const MAXFUNC% = 13
Const IHI% = 32766
Const ELEMENTS% = 1000
Const UNIT! = 300, MARGIN! = 100
Const TITLEBAR! = 295, BOARDER! = 60
Const ORANGE& = &H80C0FF
Const ICL$ = "Include"

Dim ascend As Boolean
Dim last1%, confirmtotal&
Dim sorts$(MAXFUNC), captions$(3)
Dim startarray%(IHI), sortarray%(IHI)

'=======================================================
'               The Sort Routines
'=======================================================
Private Sub Bubble_Sort(ByVal lower%, ByVal upper%)
    Dim j%, tmp%, Done As Boolean
    
    Do While Not Done
        Done = True
        upper = upper - 1
        
        For j = lower To upper
            If (ascend And _
              (sortarray(j) > sortarray(j + 1))) Or _
              (Not ascend And _
              (sortarray(j) < sortarray(j + 1))) Then
                tmp = sortarray(j)
                sortarray(j) = sortarray(j + 1)
                sortarray(j + 1) = tmp
                
                Done = False
            End If
        Next
    Loop
End Sub

'The Bubble done with a shuffle up
'Rather than the classic method of swapping with the
'  next contiguous element of an array, a SHUFFLE
'  keeps the initial element as a tmp and then makes
'  tests incrementally with next elements (making
'  single assignments along the way) until it arrives
'  at the spot where it normally be swapped to and
'  at that place the tmp is deposited. There can be
'  significant time savings (especially seen in the
'  Insertion Sort below) because with each swap three
'  assignments are required, whereas only one is
'  required when shuffling.
Private Sub Bubble2_Sort(ByVal lower%, ByVal upper%)
    Dim low%, high%, tmp%, Done As Boolean
    
    Do While Not Done
        Done = True
        low = lower
        upper = upper - 1
        
        Do Until low > upper
            tmp = sortarray(low)

            Do
                high = low + 1
                If (ascend And _
                    sortarray(high) >= tmp) Or _
                    (Not ascend And _
                    sortarray(high) <= tmp) Then Exit Do
                    
                sortarray(low) = sortarray(high)
                low = high
            Loop Until low > upper

            If sortarray(low) <> tmp Then
                sortarray(low) = tmp
                Done = False
            End If
            low = high
        Loop
    Loop
End Sub

Private Sub BiBubble_Sort(ByVal lower%, ByVal upper%)
    Dim j%, tmp%, Done As Boolean
        
    Do While Not Done
        Done = True
        upper = upper - 1
        
        For j = lower To upper
            If (ascend And _
              (sortarray(j) > sortarray(j + 1))) Or _
              (Not ascend And _
              (sortarray(j) < sortarray(j + 1))) Then
                tmp = sortarray(j)
                sortarray(j) = sortarray(j + 1)
                sortarray(j + 1) = tmp
                Done = False
            End If
        Next
        
        If Done Then Exit Do
        lower = lower + 1
        
        For j = upper To lower Step -1
            If (ascend And _
              (sortarray(j) < sortarray(j - 1))) Or _
              (Not ascend And _
              (sortarray(j) > sortarray(j - 1))) Then
                tmp = sortarray(j)
                sortarray(j) = sortarray(j - 1)
                sortarray(j - 1) = tmp
                Done = False
            End If
        Next
    Loop
End Sub

'The Bi-Bubble done with a shuffle up
Private Sub BiBubble2_Sort(ByVal lower%, ByVal upper%)
    Dim low%, high%, tmp%, Done As Boolean
    
    Do While Not Done
        Done = True
        low = lower
        upper = upper - 1
        
        Do Until low > upper
            tmp = sortarray(low)

            Do
                high = low + 1
                If (ascend And _
                    sortarray(high) >= tmp) Or _
                    (Not ascend And _
                    sortarray(high) <= tmp) Then Exit Do
                    
                sortarray(low) = sortarray(high)
                low = high
            Loop Until low > upper

            If sortarray(low) <> tmp Then
                sortarray(low) = tmp
                Done = False
            End If
            low = high
        Loop
        
        If Done Then Exit Do
        high = upper
        lower = lower + 1
        
        Do Until lower > high
            tmp = sortarray(high)

            Do
                low = high - 1
                If (ascend And _
                    sortarray(low) <= tmp) Or _
                    (Not ascend And _
                    sortarray(low) >= tmp) Then Exit Do
                    
                sortarray(high) = sortarray(low)
                high = low
            Loop Until lower > high

            If sortarray(high) <> tmp Then
                sortarray(high) = tmp
                Done = False
            End If
            high = low
        Loop
    Loop
End Sub

Private Sub Insertion_Sort(ByVal lower%, ByVal upper%)
    Dim j%, low%, high%, tmp%
    
    For j = lower + 1 To upper
        high = j
        Do
            low = high - 1
            
            If (ascend And _
              (sortarray(low) > sortarray(high))) Or _
              (Not ascend And _
              (sortarray(low) < sortarray(high))) Then
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
                
                high = low
            Else
                Exit Do
            End If
        Loop Until high <= lower
    Next
End Sub

'The Insertion done with a shuffle down
Private Sub Insertion2_Sort(ByVal lower%, ByVal upper%)
    Dim j%, low%, high%, tmp%
    
    For j = lower + 1 To upper
        high = j
        tmp = sortarray(high)

        Do
            low = high - 1
            If (ascend And sortarray(low) <= tmp) Or _
                (Not ascend And sortarray(low) >= tmp) _
                    Then Exit Do
            sortarray(high) = sortarray(low)
            high = low
        Loop Until high <= lower

        sortarray(high) = tmp
    Next
End Sub

Private Sub Shell_Sort(ByVal lower%, ByVal upper%)
    Dim diff%, low%, high%, tmp%
    
    diff = Int(CSng(upper - lower) / 1.3)
    
    Do While diff
        high = lower + diff
        
        Do Until high > upper
            low = high - diff
            If (ascend And _
              (sortarray(low) > sortarray(high))) Or _
              (Not ascend And _
              (sortarray(low) < sortarray(high))) Then
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
                
                If diff = 1 Then
                    If (low - diff) >= lower Then
                        'Note: attempting a shuffle down
                        ' here doesn't improve speed
                        high = low - 1
                    End If
                End If
            End If
            
            high = high + 1
        Loop
        
        diff = Int(CSng(diff) / 1.3)
    Loop
End Sub

Private Sub Count_Sort(ByVal lower%, ByVal upper%)
    Dim j%, incdec%
    ReDim cnt%(IHI)

    For j = lower To upper
        cnt(sortarray(j)) = cnt(sortarray(j)) + 1
    Next
    j = 0

    If ascend Then
        incdec = 1
    Else
        incdec = lower
        lower = upper
        upper = -incdec
        incdec = -1
    End If
        
    Do Until lower * incdec > upper
        Do Until cnt(j) <> 0
            j = j + 1
        Loop
        Do While cnt(j)
            sortarray(lower) = j
            lower = lower + incdec
            cnt(j) = cnt(j) - 1
        Loop
    Loop
End Sub

Private Sub Selection_Sort(ByVal lower%, ByVal upper%, _
                    Optional interpolating As Boolean)
    Dim j%, low%, high%, tmp%
    
    Do Until lower >= upper
        high = upper
        low = lower
                
        For j = lower To upper
            If (ascend And _
                (sortarray(j) < sortarray(low))) Or _
                (Not ascend And _
                (sortarray(j) > sortarray(low))) Then
                    low = j
            ElseIf (ascend And _
                (sortarray(j) > sortarray(high))) Or _
                (Not ascend And _
                (sortarray(j) < sortarray(high))) Then
                    high = j
            End If
        Next
        
        If high <> upper Then
            If low = upper Then low = high
            tmp = sortarray(upper)
            sortarray(upper) = sortarray(high)
            sortarray(high) = tmp
        End If
        
        If low <> lower Then
            tmp = sortarray(lower)
            sortarray(lower) = sortarray(low)
            sortarray(low) = tmp
        End If
                
        'When called from the interpolation sort
        ' just one pass is necessary to set the ends
        If interpolating Then Exit Do
        lower = lower + 1
        upper = upper - 1
    Loop
End Sub

'Kind of clumsy using one pass of a Selection Sort to
'  set the ends (and the formula for the interpolation)
'  and then cleaning up with and Insertion Sort -
'  But with all these components it is speedy
Private Sub Interpolate_Sort(ByVal lower%, ByVal upper%)
    'First set the min and max at the ends
    Selection_Sort lower, upper, True
    
    ReDim previous%(lower To upper)
    Dim j%, k%, base%, offset%, dif1!, dif2!, tmp%, try%

    dif1 = CSng(upper - lower)
    dif2 = CSng(sortarray(upper) - sortarray(lower))
    base = IIf(ascend, lower, upper)
    j = lower + 1

    Do Until j >= upper
        If previous(j) = 0 Then
            offset = base + CInt(dif1 * _
            CSng(sortarray(j) - sortarray(base)) / dif2)
                    
            try = 1
            Do
                If offset <= lower Then
                    offset = lower + 1
                ElseIf offset >= upper Then
                    offset = upper - 1
                End If
            
                If previous(offset) = 0 Then
                    If j <> offset Then
                        tmp = sortarray(j)
                        sortarray(j) = sortarray(offset)
                        sortarray(offset) = tmp
                    End If
            
                    previous(offset) = -1
                    Exit Do
                ElseIf try = 1 Then
                    offset = offset + 1
                    try = 2
                ElseIf try = 2 Then
                    offset = offset - 2
                    try = 3
                Else
                    j = j + 1
                    Exit Do
                End If
            Loop
        Else
            j = j + 1
        End If
    Loop
    
    'Cleanup imprecision and duplicates
    Insertion2_Sort lower, upper
End Sub

Private Sub Merge_Sort(ByVal lower%, ByVal upper%)
    Dim tmp%
    
    Select Case upper - lower
        Case Is <= 0: Exit Sub
        Case 1
            If (ascend And _
              (sortarray(lower) > sortarray(upper))) _
              Or (Not ascend And _
              (sortarray(lower) < sortarray(upper))) Then
                    tmp = sortarray(lower)
                    sortarray(lower) = sortarray(upper)
                    sortarray(upper) = tmp
            End If
            Exit Sub
    End Select

    Dim upper1%, lower1%
    upper1 = lower + (upper - lower) \ 2
    lower1 = upper1 + 1

    Merge_Sort lower, upper1
    Merge_Sort lower1, upper

    Dim ux%, uy%

    Do While lower1 <= upper And lower <= upper1
        If (ascend And _
          (sortarray(lower) > sortarray(lower1))) Or _
          (Not ascend And _
          (sortarray(lower) < sortarray(lower1))) Then
            tmp = sortarray(lower)
            sortarray(lower) = sortarray(lower1)
                
            'Now do a shuffle up
            ux = lower1
            Do Until ux >= upper
                uy = ux + 1
                If (ascend And _
                  (tmp <= sortarray(uy))) Or _
                  (Not ascend And _
                  (tmp >= sortarray(uy))) Then Exit Do
                sortarray(ux) = sortarray(uy)
                ux = ux + 1
            Loop
            
            sortarray(ux) = tmp
        End If

        lower = lower + 1
    Loop
End Sub

Private Sub Quick_Sort(ByVal lower%, ByVal upper%)
    If lower >= upper Then Exit Sub
    
    Dim low%, midl%, high%, midval%, tmp%
    
    low = lower
    high = upper
    
    midl = lower + (upper - lower) \ 2
    midval = sortarray(midl)
 
    Do While low <= high
        Do Until low >= upper
            If (ascend And _
                sortarray(low) >= midval) Or _
                (Not ascend And _
                sortarray(low) <= midval) Then Exit Do
            low = low + 1
        Loop
     
        Do Until high <= lower
            If (ascend And _
                midval >= sortarray(high)) Or _
                (Not ascend And _
                midval <= sortarray(high)) Then Exit Do
            high = high - 1
        Loop
 
        If low <= high Then
            If low < high Then
                tmp = sortarray(low)
                sortarray(low) = sortarray(high)
                sortarray(high) = tmp
            End If
            low = low + 1
            high = high - 1
        End If
    Loop

    If lower < high Then Quick_Sort lower, high
    If low < upper Then Quick_Sort low, upper
End Sub

Private Sub Heap_Sort(ByVal lower%, ByVal upper%)
    Dim j%, tmp%

    j = upper - (upper - lower) \ 2
    
    Do Until j >= upper
        SiftUp upper, j, lower
        j = j + 1
    Loop

    For j = lower To upper - 1
        If (ascend And _
          (sortarray(upper) < sortarray(j))) Or _
          (Not ascend And _
          (sortarray(upper) > sortarray(j))) Then
            tmp = sortarray(upper)
            sortarray(upper) = sortarray(j)
            sortarray(j) = tmp
            
            SiftUp upper, upper - 1, j
        End If
    Next
End Sub
Private Sub SiftUp(first%, ByVal midl%, last%)
    Dim k&, k1%, m1%, tmp%
    
    k = CLng(midl - first) * 2 + first
    Do While k >= last
        If k > last Then
            k1 = k + 1
            If (ascend And _
              (sortarray(k) < sortarray(k1))) Or _
              (Not ascend And _
              (sortarray(k) > sortarray(k1))) Then
                k = k - 1
            End If
        End If
        
        k1 = k + 1
        m1 = midl + 1
        If (ascend And _
          (sortarray(k1) < sortarray(m1))) Or _
          (Not ascend And _
          (sortarray(k1) > sortarray(m1))) Then
            tmp = sortarray(k1)
            sortarray(k1) = sortarray(m1)
            sortarray(m1) = tmp
        Else
            Exit Do
        End If
        midl = k
        k = CLng(midl - first) * 2 + first
    Loop
End Sub

'=======================================================
'              Button Procedures
'=======================================================
Private Sub Command1_MouseUp(Index%, _
                        Button%, Shift%, X!, Y!)
    Select Case Index
        Case 0: Reset Button
        Case 1: UpDn Index
        Case 2: DoTimings
        Case 3: IncALL
        Case Else: Toggle Index, Button
    End Select
End Sub

Private Sub Reset(ByVal b%)
    Static i%, j%, s!
    Static b1%
    
    ChangeColor ORANGE
    MousePointer = vbHourglass
    DoEvents
    
    If b = 0 Then b = b1
    s = CSng(last1 + 1)
    If b = 1 Then
        For i = 0 To last1
            Randomize
            startarray(i) = Int(s * Rnd)
        Next
    Else
        For i = 0 To last1
            sortarray(i) = i
            startarray(i) = -1
        Next
        For i = 0 To last1
            Randomize
            j = Int(s * Rnd)
            Do While startarray(j) >= 0
                j = j + 1
                If j > last1 Then j = 0
            Loop
            startarray(j) = sortarray(i)
        Next
    End If

    ChangeColor vbButtonShadow
    b1 = b
    MousePointer = vbDefault
End Sub

Private Sub ChangeColor(ByVal clr&)
    Static i%
    
    For i = 0 To MAXFUNC * 3 + 3
        Label1(i).BackColor = clr
    Next
    
    Form1.BackColor = clr
    DoEvents
End Sub

Private Sub UpDn(ByVal i%)
    With Command1(i)
      If ascend Then
        .Caption = "Descend"
        .ToolTipText = "Click for Ascending"
        ascend = False
      Else
        .Caption = "Ascend"
        .ToolTipText = "Click for Descending"
        ascend = True
      End If
    End With
End Sub
    
Private Sub IncALL()
    Dim i%
    For i = BUTTONS To MAXFUNC + BUTTONS - 1
        Command1(i).Caption = ICL
    Next
End Sub

Private Sub Toggle(ByVal i%, ByVal b%)
    Static j%, s$
    s = ICL
    
    If b = 1 Then
        If Command1(i).Caption = ICL Then s = "Exclude"
    Else
        For j = BUTTONS To MAXFUNC + BUTTONS - 1
            Command1(j).Caption = "Exclude"
        Next
    End If
    
    Command1(i).Caption = s
End Sub

Private Sub DoTimings()
    Static i%, func%, t1&, t2&
    Static lower%, upper%
    Static flag As Boolean
    
    Screen.MousePointer = vbHourglass
    ChangeColor vbButtonShadow
    
    For lower = MAXFUNC To MAXFUNC * 3 - 1
        Label1(lower).Caption = ""
    Next
    
    confirmtotal = 0
    For i = 0 To last1
        confirmtotal = confirmtotal + startarray(i)
    Next
    
    lower = 0: upper = last1
    
    For func = BUTTONS To MAXFUNC + BUTTONS - 1
        If Command1(func).Caption = ICL Then
            For i = 0 To last1
                sortarray(i) = startarray(i)
            Next
            DoEvents

            t1 = GetTime
            Select Case func
                Case 4: Bubble_Sort 0, last1
                Case 5: Bubble2_Sort 0, last1
                Case 6: BiBubble_Sort 0, last1
                Case 7: BiBubble2_Sort 0, last1
                Case 8: Insertion_Sort 0, last1
                Case 9: Insertion2_Sort 0, last1
                Case 10: Shell_Sort 0, last1
                Case 11: Count_Sort 0, last1
                Case 12: Selection_Sort 0, last1
                Case 13: Interpolate_Sort 0, last1
                Case 14: Merge_Sort 0, last1
                Case 15: Quick_Sort 0, last1
                Case 16: Heap_Sort 0, last1
            End Select
            t2 = GetTime
            
            DoEvents
            flag = ShowTime(t1, t2, func)
        End If
    Next
    
    If flag Then
        For lower = 0 To last1
            startarray(lower) = sortarray(lower)
        Next
    
        ChangeColor ORANGE
    End If
    
    Screen.MousePointer = vbDefault
End Sub

Private Function GetTime&()
    timeGetSystemTime mmt, L1
    GetTime = mmt.units
End Function

Private Function ShowTime(start&, stopp&, ByVal i%) _
        As Boolean
    i = i - BUTTONS
    Label1(i + MAXFUNC).Caption = CStr(stopp - start)
    ShowTime = Confirm(i)
End Function

Private Function Confirm(ByVal i%) As Boolean
    Static j%, s$
    Dim l&
    
    s = "success"
    Confirm = True
    l = sortarray(0)
    
    For j = 1 To last1
        l = l + sortarray(j)
        If (ascend And _
            (sortarray(j) < sortarray(j - 1))) Or _
            (Not ascend And _
            (sortarray(j) > sortarray(j - 1))) Then
                s = "!order!"
                Confirm = False
                Exit For
        End If
    Next
    
    If l <> confirmtotal Then
        s = "!total!"
        Confirm = False
    End If
    
    Label1(i + MAXFUNC * 2).Caption = s
End Function

'=======================================================
'   Handle the TextBox for Number of Elements Input
'=======================================================
Private Sub Text1_KeyUp(KeyCode%, Shift%)
    If KeyCode = vbKeyReturn Then Command1(2).SetFocus
End Sub

Private Sub Text1_LostFocus()
    Dim d#, i%
    
    d = Val(Text1.Text)
    If d < 100 Or d > IHI Then
        i = last1 + 1
    Else
        i = CInt(d)
        last1 = i - 1
        Reset 0
    End If
    
    Text1.Text = CStr(i)
End Sub

'=======================================================
'              Initialization
'=======================================================
Private Sub Form_Load()
    Const WDTH = UNIT * 3
    Dim i%, j%, lt!, tp!, tp1!, w!
    
    ascend = True
    last1 = ELEMENTS - 1
    mmt.wType = TIME_MS
    L1 = LenB(mmt)
    
    Height = BOARDER * 2 + TITLEBAR + _
        (UNIT + MARGIN) * (MAXFUNC + 3)
    Width = (MARGIN + BOARDER) * 2 + _
        UNIT * 15 + MARGIN * 4
    BackColor = vbButtonShadow
    Caption = "Sorting Timer"
    
    AddButton "Randomize", _
            "Right click for all different numbers"
    AddButton "Ascend", "Click for Descending"
    AddButton "Timings", "Perform Timings"
    
    tp = MARGIN + UNIT
    lt = BOARDER + MARGIN + (MARGIN + UNIT * 4) * 3
    
    With Text1
        .Move lt, MARGIN + UNIT, WDTH, UNIT
        .Text = CStr(ELEMENTS)
    End With
    
    sorts(0) = "Bubble"
    sorts(1) = "Bubble2"
    sorts(2) = "Bi-Bubble"
    sorts(3) = "Bi-Bubble2"
    sorts(4) = "Insertion"
    sorts(5) = "Insertion2"
    sorts(6) = "Shell"
    sorts(7) = "Count"
    sorts(8) = "Selection"
    sorts(9) = "Interpolate"
    sorts(10) = "Merge"
    sorts(11) = "Quick"
    sorts(12) = "Heap"
    
    captions(0) = "Sort Type"
    captions(1) = "Millisecs"
    captions(2) = "Verified"
    captions(3) = "Elements"
    
    lt = BOARDER + MARGIN
    tp = BOARDER + (MARGIN + UNIT) * 2
    
    For j = 0 To MAXFUNC
        i = j + 3
        Load Command1(i)
        
        With Command1(i)
            .Move lt, tp, WDTH, UNIT
            .FontBold = True
            .Visible = True
          If j Then
            .Caption = ICL
            .ToolTipText = "Right click for only this"
          Else
            .Caption = "ALL"
            .ToolTipText = "Include all methods"
          End If
        End With
        tp = tp + MARGIN + UNIT
    Next
    DoEvents
    
    tp = BOARDER + MARGIN * 3 + WDTH
    tp1 = tp
    lt = BOARDER + MARGIN * 2 + WDTH
    w = UNIT * 5
    
    For j = 0 To MAXFUNC - 1
        If j Then Load Label1(j)
        
        With Label1(j)
            .Move lt, tp, w, UNIT
            .BackColor = vbButtonShadow
            .Caption = sorts(j)
            .FontBold = True
            .Visible = True
            .Alignment = 1
        End With
        tp = tp + MARGIN + UNIT
    Next
    
    DoEvents
    tp = tp1
    lt = MARGIN * 3 + UNIT * 8
    w = UNIT * 4
    
    For j = 0 To MAXFUNC - 1
        i = j + MAXFUNC
        Load Label1(i)
        
        With Label1(i)
            .Move lt, tp, w, UNIT
            .FontBold = True
            .Visible = True
            .Alignment = 1
            .Caption = ""
        End With
        tp = tp + MARGIN + UNIT
    Next
    
    DoEvents
    tp = tp1
    lt = BOARDER + MARGIN * 4 + UNIT * 12
    
    For j = 0 To MAXFUNC - 1
        i = j + MAXFUNC * 2
        Load Label1(i)
        
        With Label1(i)
            .Move lt, tp, WDTH, UNIT
            .FontBold = True
            .Visible = True
            .Caption = ""
        End With
        tp = tp + MARGIN + UNIT
    Next
    
    DoEvents
    tp = MARGIN * 3 + UNIT * 2
    lt = BOARDER + MARGIN * 2 + UNIT * 5
    
    For j = 0 To 3
        i = j + MAXFUNC * 3
        Load Label1(i)
        
        With Label1(i)
            .Move lt, tp, WDTH, UNIT
            .Caption = captions(j)
            .FontBold = True
            .Visible = True
            .Alignment = 2
        End With
        
        Select Case j
            Case 0: lt = lt + MARGIN + WDTH + UNIT
            Case 2: tp = MARGIN
            Case Else: lt = lt + MARGIN + WDTH
        End Select
    Next
    
    DoEvents
    Reset 1
End Sub

Private Sub AddButton(s$, Optional tip$ = "")
    Const HT! = UNIT * 2, WD! = UNIT * 4
    Static num%, j%, lt!
    
    If num Then
        Load Command1(num)
    Else
        lt = BOARDER + MARGIN
    End If
        
    With Command1(num)
        .Move lt, MARGIN, WD, HT
        .ToolTipText = tip
        .FontBold = True
        .Visible = True
        .Caption = s
    End With
    
    lt = lt + MARGIN + UNIT * 4
    num = num + 1
End Sub
Press F5 to run the timer. Immediately you will see the Form Window pictured above and be able to time the sorts by clicking on Timings.
The Controls Across the Top

Randomize
Left click on this button to populate the array with integers, duplicates allowed. Right click to randomize with all different numbers - no duplicates. It may take a little while to randomize large arrays. The backcolor of the timer will turn to brown when done.


Ascend
This button toggles ascend with descend to indicate the direction in which the array will be sorted. After an array is sorted, change direction and see how long it takes to sort when the array is completely ordered in the opposite direction. You might also check to see how long the various methods take to sort an array that is already sorted (in the same direction).


Timings
Click this to perform the timings. The time for each method included will be displayed in milliseconds (1000 = 1 second) as the individual sorts complete. Note that each method will be sorting the exact same array (element values in the same order) to give true comparability.

The timing uses an API call and includes no DoEvents while sorting for the most accurate timing. That means, however, that your computer will seem to lock up while sorting. While running from the VB editor, you may stop at any time by pressing [Ctrl][Break].


Elements
Enter a different number in the textbox to change the number of elements to be sorted (minimum 100, maximum 32766). After changing the value (and pressing enter or tabbing) the backcolor will change to orange while the new size array is being populated and randomized. Wait for it to turn brown again.

For elements exceeding 10,000, you may want to include just the fastest sorting methods (Count, Heap, Quick, and Shell). Refer to the my timings chart below.


The Command Buttons down the Side

Include
Include buttons toggle with Exclude allowing you to time only certain sorting methods. Right click to quickly select only one method.


Confirm
Sorted arrays are checked after each sort to ascertain that they are truly ordered (!order! if failed). Further a checksum is verified to be sure all the numbers are there (!total! if failed). If both checks are passed then this column will show the word success. The array is ordered if the last timed sort succeeds. This allows you to toggle ascend and sort the array with elements in completely reversed order.

My timings on these methods from the VB editor on my AMD K6-450 computer: 
                                    (max)
                 1000     10000     32766 ELEMENTS

  Bubble         1120    116080   1255291 *
  Bi-Bubble       737     72746    775511
  Heap            111      1518      5658
  Insertion       475     46924    500731
  Merge           530     51087    542587
  Quick            31       405      1443
  Selection       992     99469   1069354
  Shell            77      1121      4220
  Interpolate     282     26752    325239
  Count             5        37       119

  * Note 1255291 is about 21 minutes