Re: VB6 LISTBOX problem

"Ivar" <ivar.ekstromer000@xxxxxxxxxxxx> wrote in message news:wEsSi.15502$8c4.425@xxxxxxxxxxxxxxxxxxxxxxx

Ummmm. Please prove me wrong. I once tried various sorting
algorithms to sort a collection . . .

That doesn't surprise me. I've always found collections to be very inefficient.

I found that the listbox was the fastest (and simplist) way to do it.
So: Have a look at the code below, can you do a sort that is faster
than this code can do?

Certainly.

On my primative dinosaur of a PC running XP it takes about 5 seconds.

We must have similar dinosaurs because it takes about 5 seconds on my machine as well :-(

There are of course all sorts of ways of sorting stuff, especially stuf that is "linked together" as in your UDTs, but to prove the following code sorts it in exactly the same way that your own original code does so, by concatenating all three items of each element into a composite string exactly as you are already doing, but instead of dumping those composite strings into a ListBox it dumps them into a VB string array. The code then sorts that array.

Also there are of course many different sorting algorithms (Bubble sort, Shell Sort, Shell Index Sort, QSort, Quicksort and others) but I've gone straight for the jugular and used what is probably the fastest string sorting algorithm you can get as far as sorting strings is concerned. It achieves its speed by sorting the string pointers "in situ" rather than sorting the string data itself (a method for which you shold thank Olaf Schmidt). However, even much simpler string sorting methods will definitely beat the ListBox method.

In this particular example (as in your own) the total time displayed includes the time taken to initially concatenate the three parts of the data as well as the sort itself.

Here's your own code, amended to use the sorting routine instead of the ListBox method, so you can paste it into a VB Form containing just a Command button. You should find it to be considerably fatser than the ListBox method, even though it still includes the "string concatenation" time.

Mike

Option Explicit
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
cElements As Long
lLbound As Long
End Type
Private Declare Sub BindArray Lib "kernel32" _
Alias "RtlMoveMemory" (pArr() As Any, PSrc&, _
Optional ByVal cb& = 4)
Private Declare Sub ReleaseArray Lib "kernel32" _
Alias "RtlMoveMemory" (pArr() As Any, _
Optional PSrc& = 0, Optional ByVal cb& = 4)
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Any) As Long
Private Declare Function GetTickCount& Lib "kernel32" ()
Private Type SomeType
ANum As Long
AString1 As String
AString2 As String
End Type
Private MyType() As SomeType
Private RumAndCoke(47000) As String

Private Sub QSort1DP(Arr() As String)
Dim i As Long, j As Long, Lo As Long, Hi As Long
Dim StPtr As Long, V(0) As String, pV() As Long
Dim sapV As SAFEARRAY1D, pArr() As Long
Dim sapArr As SAFEARRAY1D, p As Long
Dim StSize As Long, StLo() As Long, StHi() As Long
StSize = 255
ReDim StLo(StSize)
ReDim StHi(StSize) 'init the stack
On Error Resume Next
'spans a Long-Array (pArr()) over
' the StringPointers in Arr()
sapArr.cDims = 1
sapArr.cbElements = 4 'Bytes used by each StrPointer
sapArr.pvData = VarPtr(Arr(0))
sapArr.cElements = UBound(Arr) - LBound(Arr) + 1
If Err Then
Err.Clear
Exit Sub 'Arr was not initialized
End If
On Error GoTo 0 'switch off Err-Handler for speed
BindArray pArr, VarPtr(sapArr)
' another Array, used to hold only one
' single String, respective its pointer
' for reasons of comparing inside the algo
sapV.cDims = 1
sapV.cbElements = 4
sapV.pvData = VarPtr(V(0))
sapV.cElements = 1
BindArray pV, VarPtr(sapV)
StPtr = 1 'init the StackPointer
StLo(0) = LBound(Arr)
StHi(0) = UBound(Arr)
Do
StPtr = StPtr - 1
Lo = StLo(StPtr)
Hi = StHi(StPtr)
If Hi - Lo < 12 Then 'MinSort
For Lo = Lo To Hi - 1
j = Lo
For i = Lo + 1 To Hi
If Arr(i) < Arr(j) Then j = i
Next i
If j <> Lo Then
p = pArr(j): pArr(j) = pArr(Lo): pArr(Lo) = p
End If
Next Lo
Else 'QSort
Do
i = Lo: j = Hi
pV(0) = pArr((Lo + Hi) \ 2)
Do
Do While Arr(i) < V(0)
i = i + 1
Loop
Do While Arr(j) > V(0)
j = j - 1
Loop
If i <= j Then
p = pArr(i)
pArr(i) = pArr(j)
pArr(j) = p
i = i + 1
j = j - 1
End If
Loop While i <= j
If j - Lo < Hi - i Then
If i < Hi Then
StLo(StPtr) = i
StHi(StPtr) = Hi
StPtr = StPtr + 1
If StPtr >= StSize Then
StSize = StSize + StSize
ReDim Preserve StLo(StSize)
ReDim Preserve StHi(StSize)
End If
End If
Hi = j
Else
If Lo < j Then
StLo(StPtr) = Lo
StHi(StPtr) = j
StPtr = StPtr + 1
If StPtr >= StSize Then
StSize = StSize + StSize
ReDim Preserve StLo(StSize)
ReDim Preserve StHi(StSize)
End If
End If
Lo = i
End If
Loop While Lo < Hi
End If
Loop While StPtr
pV(0) = 0 'don't dump the current Content of V(0)
ReleaseArray pV 'release the Array-Mapping
ReleaseArray pArr 'relase the Array-Mapping
End Sub

Private Sub Command1_Click()
SortMyArray
End Sub

Private Sub Form_Load()
Dim L As Long
Randomize Timer
ReDim MyType(47000) As SomeType

For L = 0 To 47000
MyType(L).ANum = 1000 * Rnd
MyType(L).AString1 = Chr((26 * Rnd) + 65)
MyType(L).AString2 = Chr((26 * Rnd) + 65)
Next
End Sub

Private Sub SortMyArray()
Dim StrToAdd As String
Dim L As Long
Dim RetVal As Long
Dim ThehWnd As Long
Dim Count1 As Long
Dim Count2 As Long
Count1 = GetTickCount
'List1.Clear
Me.Cls
'ThehWnd = List1.hwnd
'Sort By AString1,ANum,AString2
For L = 0 To 47000
'StrToAdd = MyType(L).AString1 & _
Format(MyType(L).ANum, "0000") & _
MyType(L).AString2
RumAndCoke(L) = MyType(L).AString1 & _
Format(MyType(L).ANum, "0000") & _
MyType(L).AString2
'RetVal = SendMessage(ThehWnd, &H180, 0&, StrToAdd)
'SendMessage ThehWnd, &H19A, RetVal, L
Next
QSort1DP RumAndCoke
'List1.Visible = True
Count2 = GetTickCount
For L = 0 To 20
Me.Print RumAndCoke(L)
'Me.Print MyType(List1.ItemData(L)).AString1;
'Me.Print vbTab & MyType(List1.ItemData(L)).ANum;
'Me.Print vbTab & vbTab & MyType(List1.ItemData(L)).AString2
Next
MsgBox "Took " & Count2 - Count1 & " milliseconds"
End Sub






.