Navigation

• Main Page

• Random Page
• Create a new Page
• All Pages
• Categories

• Administration
• File Management

• Login/Logout
• Language Selection
• Your Profile
• Create Account

Übersicht und Code-Beispiele für gängige Sortier Routinen. Ausserdem Aufbau eines Adhoc Recordsets, diesen sortieren und dann ausgeben

Sortier Routinen

1. Bubble Sort
2. Quick Sort
3. Heap Sort
4. ADO Sort

Bubble Sort

testarray = Array("Ford", "Jaguar", "Opel", "Audi", "Subaru", "BMW", "Alfa Romeo")
Response.Write BubbleSort(testarray)

Sub BubbleSort(ByRef A)
	Dim i, j
	For i = 0 to UBound(A) - 1
		For j = i + 1 to UBound(A)
			If a(i) < a(j) Then
				Swap a(i), a(j)
			End If
		Next
	Next
End Sub

Sub Swap(ByRef L, ByRef R)
	Dim Temp
	Temp = R
	R = L
	L = Temp
End Sub

Quick Sort

testarray = Array("Ford", "Jaguar", "Opel", "Audi", "Subaru", "BMW", "Alfa Romeo")
Response.Write QSort(testarray, Lbound(testarray), Ubound(testarray))

'      '::::::'
'      '::: Routine:QSort :::'
'      '::: Author:Mike Shaffer (after Rod Stephens, 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 non-commercial:::'
'      '::: product with credit where due. For free:::'
'      '::: commercial license contact mshaffer@nkn.net:::'

Function QSort(strList, lLbound, lUbound)
	Dim strTemp, strBuffer, lngCurLow, lngCurHigh, lngCurMidpoint
	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 StrComp( strList(lngCurLow), strTemp, vbTextCompare ) < 0
			lngCurLow = lngCurLow + 1
			If lngCurLow = lUbound Then Exit Do
			Loop
		
			Do While StrComp( strTemp, strList(lngCurHigh), vbTextCompare ) < 0
			lngCurHigh = lngCurHigh - 1
			If lngCurHigh = lLbound Then Exit Do
		Loop
	
		If (lngCurLow <= lngCurHigh) Then ' if low is <= high then swap
			Swap strList(lngCurLow), strList(lngCurHigh)
			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

Heap Sort

testarray = Array("Ford", "Jaguar", "Opel", "Audi", "Subaru", "BMW", "Alfa Romeo")
Response.Write HeapSort(testarray)

Sub HeapSort(ByRef A)
	Dim HeapSize, i
	HeapSize = UBound(A) + 1
	BuildHeap A, HeapSize
	For i = UBound(A) To 1 Step -1
		Swap A(0), A(i)
		HeapSize = HeapSize - 1
		Heapify A, 0, HeapSize
	Next
End Sub

Sub BuildHeap(ByRef A, ByVal HeapSize)
	Dim i
	For i = Int(HeapSize / 2) To 0 Step -1
		Heapify A, i, HeapSize
	Next
End Sub

Sub Heapify(ByRef A, ByVal i, ByVal HeapSize)
	Dim l, r, Largest
	l = 2 * i + 1
	r = 2 * i + 2
	Largest = i
	If l < HeapSize Then
		If A(l) > A(i) Then Largest = l
	End If
	If r < HeapSize Then
		If A(r) > A(Largest) Then Largest = r
	End If
	If Largest <> i Then
		Swap A(i), A(Largest)
		Heapify A, Largest, HeapSize
	End If
End Sub

ADO Sort

testarray = Array("Ford", "Jaguar", "Opel", "Audi", "Subaru", "BMW", "Alfa Romeo")
AdoSort testarray

Sub AdoSort(aArray)
	' Diese Konstanten sind in adovbs.inc definiert. Standardmäßig in C:\Programme\Gemeinsame Dateien\System\ado
	const adUseClient = 3
	const adInteger = 3
	const adDate = 7
	const adVarChar = 200

	Set oRS = Createobject("ADODB.Recordset")
	oRS.Cursorlocation = adUseClient
	oRS.Fields.Append "aString", adVarChar, 20
	' ---- k�nnten auch mehrere Felder sein
	'   oRS.Fields.Append "aInt", adInteger   ' Beispiel f�r ein Integerfeld
	'   oRS.Fields.Append "aDatum", adDate    ' Beispiel f�r ein Zeit/Datumsfeld
	oRS.Open

	For i = 1 to UBound(testarray)
		oRS.AddNew
		oRS.Fields("aString").value = aArray(i)
		' oRS.Fields("aInt").value = 4711  ' falls es mehrere Felder werden sollen
		oRS.Update
	Next

	oRS.Sort = "aString ASC" ' Feld absteigend sortieren
	oRS.Movefirst

	Response.Write "<table>"	
	Do Until oRS.Eof
		Response.Write "<td>"
		For each f in oRS.fields  ' diese Schleife braucht es nur bei mehreren Feldern
			Response.Write "<td>" & f.name & " = " & f.value & "</td>"
		Next
		' -- simple Ausgabe bei einem Feld
		' Response.Write "<td>" & oRS("aString").name & " = " & oRS("aString").value & "</td>"
		' -----
		oRS.movenext
		Response.Write "</td>"
	Loop
	Response.Write "</table>"	
End Sub

Weiterführende Links

• http://www.devx.com/vb/Article/17313/0 (Englischsprachiger Artikel)
• http://www.sortieralgorithmen.de/