UNKNOWN '************************************** ' Name: qsort ' Description:Want to sort 5,000 10-byte ' strings in about 1/10th of a second? Thi ' s will do it (at least on my PII-233!). ' The insertion sort manages the same task ' in about 60 seconds (even when optimized ' it still took about 15 seconds on the sa ' me machine). ' By: Mike Shaffer ' ' ' Inputs:strList (a string array) ' ' Returns:strList (the same array - sort ' ed) ' 'Assumes:Want to sort 5,000 10-byte stri ' ngs in about 1/10th of a second? This wi ' ll do it (at least on my PII-233!). The ' insertion sort manages the same task in ' about 60 seconds (even when optimized it ' still took about 15 seconds on the same ' machine). ' 'Side Effects:none 'This code is copyrighted and has limite ' d warranties. 'Please see http://www.Planet-Source-Cod ' e.com/xq/ASP/txtCodeId.897/lngWId.1/qx/v ' b/scripts/ShowCode.htm 'for details. '************************************** Public Function QSort(strList() As String, lLbound As Long, lUbound As Long) '::::::::::::::::::::::::::::::::::::::: ' ::::::::::::::::::::::::::::::' '::::::' '::: Routine:QSort :::' '::: Author:Mike Shaffer (after Rod Step ' hens, et al.) :::' '::: Date: 21-May-98 :::' '::: Purpose:Very fast sort of a string ' array :::' '::: Passed:strListString array:::' '::: lLboundLower bound to sort (usually ' 1) :::' '::: lUboundUpper bound to sort (usually ' ubound()) :::' '::: Returns:strList(in sorted order)::: ' '::: Copyright: Copyright *c* 1998, Mike ' Shaffer :::' '::: ALL RIGHTS RESERVED WORLDWIDE :::' '::: Permission granted to use in any no ' n-commercial:::' '::: product with credit where due. For ' free:::' '::: commercial license contact mshaffer ' @nkn.net:::' '::: Revisions: 22-May-98 Added and then ' dropped revision :::' '::: using CopyMemory rather than the si ' mple swap :::' '::: when it was found to not provide mu ' ch benefit.:::' '::::::' '::::::::::::::::::::::::::::::::::::::: ' ::::::::::::::::::::::::::::::' Dim strTemp As String Dim strBuffer As String Dim lngCurLow As Long Dim lngCurHigh As Long Dim lngCurMidpoint As Long lngCurLow = lLbound' Start current low and high at actual low/high lngCurHigh = lUbound If lUbound <= lLbound Then Exit Function ' Error! lngCurMidpoint = (lLbound + lUbound) \ 2 ' Find the approx midpoint of the array strTemp = strList(lngCurMidpoint) ' Pick as a starting point (we are making ' an assumption that the data *might* be ' ' in semi-sorted order already! Do While (lngCurLow <= lngCurHigh) Do While strList(lngCurLow) < strTemp lngCurLow = lngCurLow + 1 If lngCurLow = lUbound Then Exit Do Loop Do While strTemp < strList(lngCurHigh) lngCurHigh = lngCurHigh - 1 If lngCurHigh = lLbound Then Exit Do Loop If (lngCurLow <= lngCurHigh) Then ' if low is <= high then swap strBuffer = strList(lngCurLow) strList(lngCurLow) = strList(lngCurHigh) strList(lngCurHigh) = strBuffer ' lngCurLow = lngCurLow + 1 ' CurLow++ lngCurHigh = lngCurHigh - 1' CurLow-- End If Loop If lLbound < lngCurHigh Then ' Recurse if necessary QSort strList(), lLbound, lngCurHigh End If If lngCurLow < lUbound Then' Recurse if necessary QSort strList(), lngCurLow, lUbound End If End Function