fivesorts.bas

包含5种排序算法

'***************************************************************************
' Name: 5 different sorts
' Description:The base application shown here was obtained over t
'     he web, from an unknown author.
The actual application consists of 2 parts - the first, a simple 30-element sort comparison (in the upper frame), and the second a more intense speed comparison between the 4 sort methods presented.
I have added code to display the actual number of times (iterations) the various routines swapped values; this code is commented and should be removed for any actual implementation of any sort method here. In addition, because the Bubble and Selection sorts can take a very long time with a large number of items to sort, I have added "Skip" buttons to abort that aspect of the speed test. I realize that the addition of Doevents somewhat skews the time reported to perform the Bubble and Selection sorts, but not as much as you might think.
' By: VB Net (Randy Birch)
'
'***************************************************************************
Option Explicit
'     'variables for the Quick sort iteration as the sub is recursive 
Global QSCallCnt As Integer
Global QSSwaps As Integer
'     'variable for the Bubble sort as the sub can be aborted 
Global Bcnt As Long
'     'variable for the Selection sort as the sub can be aborted 
Global SScnt As Long
'     'used to abandon long sorts 
Global SkipFlag As Integer

Public Sub BubbleSortNumbers(iArray As Variant)

       Dim lLoop1 As Long
       Dim lLoop2 As Long
       Dim lTemp As Long
       frmSorts.lblIterations(0) = "Working..."

              For lLoop1 = UBound(iArray) To LBound(iArray) Step -1
                      

                            For lLoop2 = LBound(iArray) + 1 To lLoop1
                                    If iArray(lLoop2 - 1) > iArray(lLoop2) Then
                                    lTemp = iArray(lLoop2 - 1)
                                    iArray(lLoop2 - 1) = iArray(lLoop2)
                                    iArray(lLoop2) = lTemp
                                    
                                   '     '----------------------------------------------------
                                   '      'Required for the speed Test; comment out for real use
                                   '      'update the iterations label 
                                    Bcnt = Bcnt + 1
                                    DoEvents
                                    If SkipFlag% Then Exit Sub
                                   '     '---------------------------------------------------- 
                                    
                                    End If
                            Next lLoop2

              Next lLoop1

       frmSorts.lblIterations(0) = "Elements swapped : " & Bcnt
        
End Sub


Public Sub SelectionSortNumbers(vArray As Variant)

        
       Dim lLoop1 As Long
       Dim lLoop2 As Long
       Dim lMin As Long
       Dim lTemp As Long
       frmSorts.lblIterations(1) = "Working..."

              For lLoop1 = LBound(vArray) To UBound(vArray) - 1
                     lMin = lLoop1

                            For lLoop2 = lLoop1 + 1 To UBound(vArray)

                                          If vArray(lLoop2) < vArray(lMin) Then
                                                  lMin = lLoop2
                                                 '      '----------------------------------------------------
                                                 '     'comment out for real use
                                                 '     'update the iterations label
                                                 SScnt = SScnt + 1
                                                 '      '----------------------------------------------------
                                          End If

                                    
                                   '      '----------------------------------------------------
                                   '      'Required for the speed Test; comment out for real use

                                          DoEvents

                                                        If SkipFlag% Then Exit Sub
                                                               '      '----------------------------------------------------
                                                                
                                                        Next lLoop2

                                                 lTemp = vArray(lMin)
                                                 vArray(lMin) = vArray(lLoop1)
                                                 vArray(lLoop1) = lTemp
                                                  
                                          Next lLoop1

                                    
                                   frmSorts.lblIterations(1) = "Elements swapped : " & SScnt
                                    
                            End Sub


Public Sub ShellSortNumbers(vArray As Variant)

       Dim lLoop1 As Long
       Dim lHold As Long
       Dim lHValue As Long
       Dim lTemp As Long
       Dim SHcnt As Integer
       frmSorts.lblIterations(2) = "Working..."
       lHValue = LBound(vArray)

              Do
                     lHValue = 3 * lHValue + 1
              Loop Until lHValue > UBound(vArray)

        

              Do
                     lHValue = lHValue / 3

                            For lLoop1 = lHValue + LBound(vArray) To UBound(vArray)
                                   lTemp = vArray(lLoop1)
                                   lHold = lLoop1

                                          Do While vArray(lHold - lHValue) > lTemp
                                                 vArray(lHold) = vArray(lHold - lHValue)
                                                 lHold = lHold - lHValue
                                                 '     '----------------------------------------------------
                                                 '      'Required for the speed Test; comment out for real use
                                                 '      'update the iterations label
                                                  SHcnt = SHcnt + 1
                                                  DoEvents
                                                 '     '----------------------------------------------------

                                                        If lHold < lHValue Then Exit Do
                                                        Loop

                                                 vArray(lHold) = lTemp
                                          Next lLoop1

                                    
                            Loop Until lHValue = LBound(vArray)

                      frmSorts.lblIterations(2) = "Elements swapped : " & SHcnt
              End Sub


Public Sub QuickSortNumbers(iArray As Variant, l&, r&)

       '     'iArray() The iArray to sort
       '     'l& First element of iArray to start sort
       '     'r& Last element of iArray to start sort
        
       '     '----------------------------------------------------
       '     'update the call count label ; comment out for real use
       QSCallCnt = QSCallCnt + 1 
       '     '---------------------------------------------------- 
        
       Dim i&, j&
       Dim X
       Dim Y
        
       i& = l&
       j& = r&
       X = iArray((l& + r&) / 2)
        

              While (i& <= j&)
                      

                            While (iArray(i&) < X And i& < r&)
                                   i& = i& + 1
                            Wend


                            While (X < iArray(j&) And j& > l&)
                                   j& = j& - 1
                            Wend


                            If (i& <= j&) Then
                                   Y = iArray(i&)
                                   iArray(i&) = iArray(j&)
                                   iArray(j&) = Y
                                   i& = i& + 1
                                   j& = j& - 1
                                    
                                   '     '----------------------------------------------------
                                   '     'update the swap count label ; comment out for real use
                                   QSSwaps = QSSwaps + 1
                                   '     '---------------------------------------------------- 
                            End If

                      
              Wend

        

              If (l& < j&) Then QuickSortNumbers iArray, l&, j&

                            If (i& < r&) Then QuickSortNumbers iArray, i&, r&
                                    
                                   frmSorts.lblIterations(3) = "Sub was called : " & QSCallCnt & " times"
                                   frmSorts.lblIterations(4) = "Elements Swapped : " & QSSwaps
                            End Sub

                     In the form, add the following code:
                     '     'general declarations
                     Option Explicit
                     '     'Used for the counter in the speed test
                     Dim tmrCounter As Long 
                     '     'flag for the timer
                     Dim sortMethod As Integer

Private Sub cmdEnd_Click()

       Unload Me
End Sub


Private Sub Form_Unload(Cancel As Integer)

        Set Form1 = Nothing
        End
End Sub


Private Sub cmdSkipBubbleSort_Click()

       SkipFlag = True
End Sub


Private Sub cmdSkipSelectionSort_Click()

       SkipFlag = True
End Sub


Private Sub cmdSort_Click(Index As Integer)

       '     'The example here builds an Array of 15 elements and
       '     'places random numbers into it. The string is then printed
       '     'to screen. The array is passed to the procedure called
       '     'BubbleSortNumbers in the project Module and it performs
       'a Selection sort. Then redisplays the sorted elements to Screen.
       '     
       Dim lMyArray(0 To 30) As Long
       Dim iLoop As Integer
       Dim sBuiltString As String
       Randomize

              For iLoop = LBound(lMyArray) To UBound(lMyArray)
                     lMyArray(iLoop) = Int(Rnd * 9) + 1
                     sBuiltString = sBuiltString & " " & lMyArray(iLoop)
              Next iLoop

       lblOriginElements = sBuiltString
       sBuiltString = ""
       Select Case Index
       Case 0
       Bcnt = 0
       Call BubbleSortNumbers(lMyArray)
       Case 1
       Call SelectionSortNumbers(lMyArray)
       Case 2
       Call ShellSortNumbers(lMyArray)
       Case 3
       QSCallCnt = 0
       Call QuickSortNumbers(lMyArray, 0, UBound(lMyArray))
End Select


For iLoop = LBound(lMyArray) To UBound(lMyArray)
       sBuiltString = sBuiltString & " " & lMyArray(iLoop)
Next iLoop

lblSortedElements = sBuiltString
End Sub


Private Sub cmdSpeedTest_Click()

       Dim lMyArray() As Long
       ReDim lMyArray(0 To CLng(txtNumberOfElements - 1))
       Dim i As Integer
       Dim vTemp1 As Variant
       Dim vTemp2 As Variant
       Dim vTemp3 As Variant
       Randomize
       tmrCounter = 0
       lblSpeedTestStatus.Caption = "Building Array of " & txtNumberOfElements & " Elements ........."

              For i% = LBound(lMyArray) To UBound(lMyArray)
                     lMyArray(i%) = Int(Rnd * 100) + 1
              Next i%

       vTemp1 = lMyArray
       vTemp2 = lMyArray
       vTemp3 = lMyArray
       Frame1.Enabled = False
       '----------------------------------------------------------------
       '     -----------
       SkipFlag% = False
       cmdSkipBubbleSort.Enabled = True
       sortMethod = 1
       Bcnt = 0
       frmSorts.timSpeedTest.Enabled = True
       lblSpeedTestStatus.Caption = "Performing Bubble Sort ......"
       Call BubbleSortNumbers(lMyArray)
       lblSortTimeReport(0).Caption = "Bubble Sort Time Taken was : " & tmrCounter & " seconds"
       timSpeedTest.Enabled = False
       frmSorts.lblIterations(0) = "Elements swapped : " & Bcnt
       tmrCounter = 0
       cmdSkipBubbleSort.Enabled = False
       '----------------------------------------------------------------
       '     -----------
       SkipFlag% = False
       cmdSkipSelectionSort.Enabled = True
       sortMethod = 2
       SScnt = 0
       frmSorts.timSpeedTest.Enabled = True
       lblSpeedTestStatus.Caption = "Performing Selection Sort ......"
       Call SelectionSortNumbers(vTemp1)
       lblSortTimeReport(1).Caption = "Selection Sort Time Taken was : " & tmrCounter & " seconds"
       timSpeedTest.Enabled = False
       frmSorts.lblIterations(1) = "Elements swapped : " & SScnt
       tmrCounter = 0
       cmdSkipSelectionSort.Enabled = False
       '----------------------------------------------------------------
       '     -----------
       sortMethod = 3
       frmSorts.timSpeedTest.Enabled = True
       lblSpeedTestStatus.Caption = "Performing Shell Sort ......"
       Call ShellSortNumbers(vTemp2)
       lblSortTimeReport(2).Caption = "Shell Sort Time Taken was : " & tmrCounter & " seconds"
       timSpeedTest.Enabled = False
       tmrCounter = 0
       '----------------------------------------------------------------
       '     -----------
       frmSorts.lblIterations(3) = "Working..."
        
       sortMethod = 4
       frmSorts.timSpeedTest.Enabled = True
       lblSpeedTestStatus.Caption = "Performing Shell Sort ......"
       Call QuickSortNumbers(vTemp3, 0, UBound(vTemp3))
       lblSortTimeReport(3).Caption = "Quick Sort Time Taken was : " & tmrCounter & " seconds"
       timSpeedTest.Enabled = False
       lblSpeedTestStatus.Caption = "Completed Speed Test ......"
       '----------------------------------------------------------------
       '     -----------
       Frame1.Enabled = True
End Sub


Private Sub timSpeedTest_Timer()

       tmrCounter = tmrCounter + 1

              If sortMethod = 1 Then
                     lblSortTimeReport(0).Caption = _
                     "Bubble Sort Time Taken was : " & tmrCounter & " seconds"
              End If


              If sortMethod = 2 Then
                     lblSortTimeReport(1).Caption = _
                     "Selection Sort Time Taken was : " & tmrCounter & " seconds"
              End If


              If sortMethod = 3 Then
                     lblSortTimeReport(2).Caption = _
                     "Shell Sort Time Taken was : " & tmrCounter & " seconds"
              End If


              If sortMethod = 4 Then
                     lblSortTimeReport(2).Caption = _
                     "Quick Sort Time Taken was : " & tmrCounter & " seconds"
              End If

End Sub