VB 5/6-Tipp 0645: Daten mit Quicksort sortieren (ASM)
von Daniel Aue
Beschreibung
Hier wird gezeigt, wie man durch Einsatz von Assemler die Sortierung von Feldern erheblich beschleunigen kann. Die Ausführung der Quicksort-Routine kann in Assembler bis zu zehnmal schneller sein als in VB.
Zu diesem Tipp existieren im Tippupload die folgende(n) Aktualisierung(en):
[VB 5/6 Tippvorschlag 0392] Daten mit Quicksort sortieren (ASM)
| Schwierigkeitsgrad:
| Verwendete API-Aufrufe: QueryPerformanceCounter (PCounter), QueryPerformanceFrequency (PFrequency), Sleep, CallWindowProcA (cdByVal), CallWindowProcA (cdLong), RtlMoveMemory (memCPY) | Download: |
'Dieser Quellcode stammt von http://www.activevb.de 'und kann frei verwendet werden. Für eventuelle Schäden 'wird nicht gehaftet. 'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum. 'Ansonsten viel Spaß und Erfolg mit diesem Source! '------------- Anfang Projektdatei Project1.vbp ------------- '--------- Anfang Formular "Form1" alias Form1.frm --------- ' Steuerelement: Kombinationsliste "Combo2" ' Steuerelement: Kontrollkästchen-Steuerelement "Check2" ' Steuerelement: Kontrollkästchen-Steuerelement "Check1" ' Steuerelement: Kombinationsliste "Combo1" ' Steuerelement: Textfeld "Text1" ' Steuerelement: Listen-Steuerelement "List2" ' Steuerelement: Listen-Steuerelement "List1" ' Steuerelement: Schaltfläche "Command1" ' Steuerelement: Beschriftungsfeld "Label3" ' Steuerelement: Beschriftungsfeld "Label2" ' Steuerelement: Beschriftungsfeld "Label1" '------------------------------------------------------------- ' Dieses Formular zeigt, wie die Assembler-Routine arrSRT ' eingesetzt wird, um mittels ASM ziemlich schnell Arrays zu ' sortieren. Der ASM-Quellcode kann in der Datei arrSRT.ASM ' eingesehen und ggf. den Bedürfnissen angepaßt werden. Der ' Originalcode stammt von Daniel Aue und ist im ActiveVB- ' Upload verfügbar. Änderungen sind im Header der Datei ' arrSRT gelistet. ' ' Auf den ActiveVB-Seiten können eine Reihe Sortierroutinen ' eingesehen werden, die reinen VB-Code nutzen. Deshalb wurde ' hier auf eine "Übersetzung" der ASM-Routine verzichtet. ' '------------------------------------------------------------- ' Ein Formular mit: Label1, List1, Check1, Combo1, Text1, ' Label2, List2, Check2, Combo2, Command1 ' Label3 '------------------------------------------------------------- Option Explicit Private Const C2T As Long = 567 ' cm to twips Private arrB() As Byte ' arrays verschiedenen Private arrI() As Integer ' Typs für die Private arrL() As Long ' Sortiertests Private arrX() As Double Private arrD() As Date Private arrC() As Currency Private arrS() As String Private arrR() As Variant ' Referenz-Array Private cur(1) As Currency ' Zeitmessung Private ini As Boolean ' Initialisierungsflag ' API-Kopierfunktion Private Declare Sub memCPY _ Lib "kernel32" Alias "RtlMoveMemory" _ (ByRef hpvDest As Any, _ ByRef hpvSource As Any, _ ByVal cbCopy As Long) ' Formular mit Vorgaben füllen Private Sub Form_Load() Me.Caption = "Arrays sortieren mit ASM" Label1.Caption = "Datentyp" Label2.Caption = "Elemente" Text1.Text = "1000" Check1.Caption = "absteigend" Check2.Caption = "vorzeichenlos" Command1.Caption = "Sort" Label3.Caption = clkFMT(-clkINI) List1.Font = "Courier new" List2.Font = "Courier new" With Combo1 .AddItem "Byte" .AddItem "Integer" .AddItem "Long" .AddItem "Double" .AddItem "Date" .AddItem "Currency" .AddItem "String" .ListIndex = 2 End With With Combo2 .AddItem "Standard" .AddItem "Lexikon" .AddItem "ASCII" .ListIndex = 0 End With ini = True End Sub ' absteigend Private Sub Check1_Click() Command1_Click End Sub ' vorzeichenlos Private Sub Check2_Click() Command1_Click End Sub ' Auswahl der zu sortierenden Datentypen Private Sub Combo1_Click() Dim N1 As Long ' Anzahl beschränken N1 = Val(Text1) If N1 < 1 Or N1 > 2000000 Then MsgBox "Ungültige Elementzahl" Else ' Ein entsprechendes Array vorbereiten Select Case Combo1.ListIndex Case 0: MyRedim arrB, N1, 0, 255 Case 1: MyRedim arrI, N1, -32768, 65535 Case 2: MyRedim arrL, N1, -2147483648#, 4294967295# Case 3: MyRedim arrX, N1, -2147483648#, 4294967295# Case 4: MyRedim arrD, N1, #1/1/1980#, 372183 Case 5: MyRedim arrC, N1, -2147483648#, 429496729500000# Case 6: MyRedim arrS, N1, 0, 0 End Select End If End Sub ' Sortiermethode auswählen Private Sub Combo2_Click() Command1_Click End Sub ' Sortieren Private Sub Command1_Click() Dim flg As Long ' Werte eingegeben? If ini Then 'Flags erstellen flg = srtReferenceArr Or _ IIf(Check1.Value, srtDescending, 0) Or _ IIf(Check2.Value, srtUnsigned, 0) Or _ (Combo2.ListIndex * 8) ' Sortierfunktion aufrufen Select Case Combo1.ListIndex Case 0: MySort arrB, flg, VarPtr(arrB(0)), 1 Case 1: MySort arrI, flg, VarPtr(arrI(0)), 2 Case 2: MySort arrL, flg, VarPtr(arrL(0)), 4 Case 3: MySort arrX, flg, VarPtr(arrX(0)), 8 Case 4: MySort arrD, flg, VarPtr(arrD(0)), 8 Case 5: MySort arrC, flg, VarPtr(arrC(0)), 8 Case 6: MySort arrS, flg, VarPtr(arrS(0)), 4 End Select End If End Sub ' Formulargröße ändert sich Private Sub Form_Resize() Dim X1 As Double ' X-Position Dim Y1 As Double ' Y-Position Dim W1 As Double ' Breite Dim D1 As Double ' Abstand Dim FW As Double ' Breiten-Faktor Dim I1 As Long ' Zähler Dim A1() As String ' Steuerelement-Namen On Error Resume Next ' Größen speichern I1 = Me.Width - Me.ScaleWidth + 11.6 * C2T If Me.Width < I1 Then Me.Width = I1 FW = Me.Width / I1 I1 = Me.Height - Me.ScaleHeight _ + (3 * 0.75 + 0.5 + 4.25) * C2T If Me.Height < I1 Then Me.Height = I1 ' Steuerelemente und Angaben zerlegen A1 = Split("1.5;0;Label1;Label2;;" & _ "2.5;.8;Combo1;Text1;;" & _ "2.5;.8;Combo2;Check1;Check2;" & _ "3;0;Command1;Label3;", ";") ' Position oben Links festlegen X1 = 0.25 * C2T Y1 = 2.5 * C2T ' Für jedes Element For I1 = 0 To UBound(A1) ' Nach jedem 5. Element neue Position speichern If (I1 Mod 5) = 0 Then X1 = X1 + W1 + D1 Y1 = Y1 - 2.25 * C2T W1 = Val(A1(I1)) * C2T * FW D1 = Val(A1(I1 + 1)) * C2T * FW I1 = I1 + 2 End If ' Sollte noch ein Control existieren, ' dieses unter dem letzen ausrichten If Len(A1(I1)) > 0 Then With Me.Controls(A1(I1)) .Top = Y1 .Left = X1 .Width = W1 .Height = 0.5 * C2T End With End If ' Jetzt eine Zeile tiefer gehen Y1 = Y1 + 0.75 * C2T Next ' 1. Liste ausrichten With List1 .Top = Check2.Top + 1 * C2T .Left = 0.25 * C2T .Width = (ScaleWidth - C2T) / 2 .Height = (ScaleHeight - .Top) End With ' 2. Liste ausrichten With List2 .Top = List1.Top .Left = 0.75 * C2T + List1.Width .Width = List1.Width .Height = List1.Height End With End Sub ' Neue Anzahl Elemente -> Liste Füllen Private Sub Text1_Change() If Val(Text1.Text) Then Combo1_Click End Sub ' Ein Array ausgeben Function Display(arr, md As Boolean) Dim C1 As ListBox Dim I1 As Long Dim J1 As Long Dim J2 As Long Dim J3 As Long Dim N1 As Long ' Obergrenze N1 = UBound(arr) ' Obergrenze festlegen ' Wenn mehr als 50 Elemente vorhanden sind, ' Nur die ersten 25 nehmen und die Anzahl ' anderswo speichern J1 = N1 If J1 > 49 Then J1 = 24: J2 = N1 J3 = 0 ' Benötigte Listen leeren If md Then Set C1 = List2 Else Set C1 = List1 C1.Clear: If Not md Then List2.Clear Do ' Alle/25 Werte ausgeben For I1 = J3 To J1 C1.AddItem Format(arrR(I1), "(000000) ") & arr(I1) Next ' Sollte es mehr als 25 Werte geben -> Seperator einfügen If J2 Then C1.AddItem "..." J3 = N1 - 24 J1 = J2 J2 = 0 Loop Until J1 = 0 End Function ' Array redimensionieren und mit Werten Füllen Function MyRedim(arr As Variant, cnt As Variant, _ min As Variant, max As Variant) Dim T1 As String Dim T2 As String Dim I1 As Long Dim J1 As Long ' Hier werden Arrays mit dummy-Werten versehen ReDim arr(cnt - 1) ReDim arrR(cnt - 1) Randomize Timer ' Soll ein String zurückgegeben werden? If (VarType(arr) And 15) = vbString Then ' Zeichenvorrat festlegen T1 = "0123456789" _ & "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _ & "abcdefghijklmnopqrstuvwxyz" ' Jedes Element durchlaufen For I1 = 0 To cnt - 1 arrR(I1) = I1 T2 = Space(Rnd() * 20) ' Jedes Element mit 20 Zufallszahlen füllen For J1 = 1 To Len(T2) Mid$(T2, J1, 1) = Mid$(T1, 1 + Fix(Rnd() * 62)) Next J1 arr(I1) = T2 Next I1 ' Kein String Else ' Jedes Element mit Zahlen im vorgegebenen Rahmen füllen For I1 = 0 To cnt - 1 arrR(I1) = I1 arr(I1) = min + Fix(Rnd() * max) Next End If ' Neues Array anzeigen Display arr, False End Function Function MySort(arr, flg As Long, ptr As Long, cnt As Long) Dim N1 As Long Dim bar() As Byte ' Um die Anzeige bei mehrfacher Sortierung gleich zu ' behalten, den ursprünglichen Arrayinhalt sichern If UBound(arr) Then N1 = cnt * (UBound(arr) + 1) ReDim bar(N1 - 1) memCPY bar(0), ByVal ptr, N1 End If ' hier wird die Sortierroutine aufgerufen clkGET cur arrSRT arr, arrR, flg clkGET cur Label3.Caption = clkFMT(cur(1)) Display arr, True ' gesicherte Arraywerte zurückschreiben If N1 Then memCPY ByVal ptr, bar(0), N1 End Function '---------- Ende Formular "Form1" alias Form1.frm ---------- '--------- Anfang Modul "Module1" alias Module1.bas --------- '-------------------------------------------------------------- ' Sortiert ein Array mithilfe einer Assembler-Routine '-------------------------------------------------------------- ' ' Original von : Daniel Aue 03.09.2003 ' Revised von : (softKUS) - III/2004 '-------------------------------------------------------------- Option Explicit Option Compare Text Public Enum srtModes srtDescending = 1 srtUnsigned = 2 srtReferenceArr = 4 srtStandard = 0 srtLexical = 8 srtAscii = 16 srtUserDefChrMap = 24 End Enum Public Declare Function cdByVal _ Lib "user32" Alias "CallWindowProcA" _ (ByRef asm As Long, _ ByVal PA1 As Long, _ ByVal PA2 As Long, _ ByVal PA3 As Long, _ ByVal PA4 As Long) As Long ' arrSRT Sortiert ein Array ' ' CALL: arrSRT(arr, [@ref], [flg], [tbl]) ' ' IN: var:arr Array, das sortiert werden soll ' ' var:@ref Referenzarray, welches dir original ' Referenzpositionen im Array speichern ' ' lng:flg Flags ' bit 0: 0=aufsteigend (Vorgabe) ' 1=absteigend ' ' Nur numerisch ' bit 1: 0=Vorzeichen beachten (Vorgabe) ' 1=Ohne Vorzeichen sortieren ' ' Nur bei Texten ' bit 2/3: 00=standard ' 01=lexikalisch ' 10=ascii ' 11=benutzerdefiniert ' ' lng:tbl Pointer auf eine Benutzerdefinierte ' Zeichentabelle ' (Nur bei Strings) ' ' OUT: lng 0: okay ' -1: Ungültige Dimension (UBound = -1) ' -2: Nicht unterstützter Datentyp varType ' -3: Kein Datapointer (sollte nicht passieren) ' -4: Ungültige Dimention (<> 1) ' -5: Keine Dimension (keine SAR-Struktur vorhanden) ' -6: Kein Array ' -7: Fehlende Sortiertabelle ' (ungültige Flags) ' Function arrSRT( _ arr As Variant, _ Optional ref As Variant, _ Optional flg As srtModes = srtStandard, _ Optional tbl As Long) As Long Static asc(63) As Long Static std(63) As Long Static lex(63) As Long Static asm(206) As Long If asm(0) = 0 Then asm(0) = &HEC8B5590: asm(1) = &HE8575653: asm(2) = &H0 asm(3) = &H758BFA6A: asm(4) = &H6B70F08: asm(5) = &HF20C4F6 asm(6) = &HB184&: asm(7) = &HEC45FF00: asm(8) = &HF608768B asm(9) = &H27440C4: asm(10) = &HF60B368B: asm(11) = &H9C840F asm(12) = &H45FF0000: asm(13) = &H3E8366EC: asm(14) = &H8F850F01 asm(15) = &HFF000000: asm(16) = &H7E8BEC45: asm(17) = &HFFF0B0C asm(18) = &H8184&: asm(19) = &HEC45FF00: asm(20) = &H7A73123C asm(21) = &HCFBB&: asm(22) = &HF05D0300: asm(23) = &H74C00AD7 asm(24) = &HEC45FF6D: asm(25) = &H3C20538D: asm(26) = &HF70F7305 asm(27) = &H21445: asm(28) = &H6740000: asm(29) = &H4C281 asm(30) = &HE4320000: asm(31) = &H43448B66: asm(32) = &H53D80310 asm(33) = &H49104E8B: asm(34) = &H45FF4478: asm(35) = &H513FE3EC asm(36) = &H314468B: asm(37) = &HC758BC1: asm(38) = &H5EBF60B asm(39) = &H488E0489: asm(40) = &H8BF97549: asm(41) = &H144D8BF3 asm(42) = &H3301E180: asm(43) = &H38A4BC0: asm(44) = &HE74C00B asm(45) = &H4B4BF003: asm(46) = &H8AD7C18A: asm(47) = &H6881004 asm(48) = &HC033EBEB: asm(49) = &H50E4558B: asm(50) = &H25EE852 asm(51) = &H458B0000: asm(52) = &HF4658DEC: asm(53) = &H5D5B5E5F asm(54) = &H10C2: asm(55) = &H5030200: asm(56) = &H7060406 asm(57) = &H30000: asm(58) = &H0: asm(59) = &H5B002F01 asm(60) = &HB2008D00: asm(61) = &H1E00E500: asm(62) = &H7C017D01 asm(63) = &H7277727F: asm(64) = &H777277: asm(65) = &H1070100 asm(66) = &H1C8A0800: asm(67) = &H3A404839: asm(68) = &HFA7F381C asm(69) = &H1C3A4A42: asm(70) = &H3BFA7C3A: asm(71) = &H8A097DC2 asm(72) = &HC86380C: asm(73) = &H380C883A: asm(74) = &H1BEE8 asm(75) = &HE0EB00: asm(76) = &H1080100: asm(77) = &H8B660A00 asm(78) = &H40484F1C: asm(79) = &H471C3B66: asm(80) = &H4A42F97F asm(81) = &H571C3B66: asm(82) = &HC23BF97C: asm(83) = &H8B660C73 asm(84) = &H8766470C: asm(85) = &H8966570C: asm(86) = &H8CE8470C asm(87) = &HEB000001: asm(88) = &H10000DB: asm(89) = &H8000107 asm(90) = &H488F1C8B: asm(91) = &H871C3B40: asm(92) = &H4A42FA7F asm(93) = &H7C971C3B: asm(94) = &H160E8FA: asm(95) = &HEDEB0000 asm(96) = &H7030200: asm(97) = &H3080100: asm(98) = &H10702 asm(99) = &HCF748B0D: asm(100) = &HCF1C8B04: asm(101) = &H743B4048 asm(102) = &HF97F04C7: asm(103) = &H1C3B0775: asm(104) = &H42F277C7 asm(105) = &HD7743B4A: asm(106) = &H75F97C04: asm(107) = &HD71C3B05 asm(108) = &HCE8F272: asm(109) = &HEB000001: asm(110) = &H10000DD asm(111) = &H12000111: asm(112) = &H488F1C8B: asm(113) = &H8BF38B40 asm(114) = &HF185870C: asm(115) = &HF1870279: asm(116) = &HF07FF13B asm(117) = &HF38B4A42: asm(118) = &H85970C8B: asm(119) = &H870279F1 asm(120) = &H7CF13BF1: asm(121) = &HF4E8F0: asm(122) = &HD9EB0000 asm(123) = &H8030200: asm(124) = &H31A0100: asm(125) = &H10802 asm(126) = &HCF1C8B25: asm(127) = &H4CF748B: asm(128) = &H89DC5D89 asm(129) = &H4048E075: asm(130) = &H8DDC758D: asm(131) = &H4E8BC71C asm(132) = &H44B8504: asm(133) = &HF3870279: asm(134) = &H3B044E8B asm(135) = &HE77F044B: asm(136) = &HE8B0875: asm(137) = &HDF770B3B asm(138) = &H758D4A42: asm(139) = &HD71C8DDC: asm(140) = &H85044B8B asm(141) = &H279044E: asm(142) = &H4E8BF387: asm(143) = &H44B3B04 asm(144) = &H675E77C: asm(145) = &HB3B0E8B: asm(146) = &H74E8DF72 asm(147) = &HEB000000: asm(148) = &H30200B7: asm(149) = &H1C02030B asm(150) = &H8B105D8B: asm(151) = &H75898F34: asm(152) = &H74F60BE0 asm(153) = &HFC768B03: asm(154) = &H48DC7589: asm(155) = &HE8C88B40 asm(156) = &H14: asm(157) = &H4A42F677: asm(158) = &H9E8CA8B asm(159) = &H72000000: asm(160) = &H58E8F6: asm(161) = &HE5EB0000 asm(162) = &H8B505257: asm(163) = &H3C8BE075: asm(164) = &HE3CF8B8F asm(165) = &HFC4F8B03: asm(166) = &H9CDC4D39: asm(167) = &H4D8B0373 asm(168) = &H74E9D1DC: asm(169) = &H8BC03317: asm(170) = &H8A068AD0 asm(171) = &H18048A17: asm(172) = &H47474646: asm(173) = &H751A043A asm(174) = &HED754905: asm(175) = &H5858509D: asm(176) = &H3BC35F5A asm(177) = &H8B247DC2: asm(178) = &H8704C74C: asm(179) = &H8904D74C asm(180) = &H8B04C74C: asm(181) = &HC87C70C: asm(182) = &HC70C89D7 asm(183) = &HC23B0DEB: asm(184) = &HC8B097D: asm(185) = &H970C8787 asm(186) = &H74870C89: asm(187) = &H831B7F16: asm(188) = &H74000C7D asm(189) = &H5D8B530E: asm(190) = &H830C8B0C: asm(191) = &H89930C87 asm(192) = &H405B830C: asm(193) = &H7FC23B4A: asm(194) = &H543BC301 asm(195) = &H97E0C24: asm(196) = &HC24448B: asm(197) = &H13E8 asm(198) = &H24443B00: asm(199) = &H8B097D08: asm(200) = &HE8082454 asm(201) = &H4: asm(202) = &H8C259: asm(203) = &H51525059 asm(204) = &H8DE875FF: asm(205) = &HE9D1020C: asm(206) = &HC3 ' ascii-table asc(0) = &H3020100: asc(1) = &H7060504: asc(2) = &HB0A0908 asc(3) = &HF0E0D0C: asc(4) = &H13121110: asc(5) = &H17161514 asc(6) = &H1B1A1918: asc(7) = &H1F1E1D1C: asc(8) = &H23222120 asc(9) = &H27262524: asc(10) = &H2B2A2928: asc(11) = &H2F2E2D2C asc(12) = &H33323130: asc(13) = &H37363534: asc(14) = &H3B3A3938 asc(15) = &H3F3E3D3C: asc(16) = &H43424140: asc(17) = &H47464544 asc(18) = &H4B4A4948: asc(19) = &H4F4E4D4C: asc(20) = &H53525150 asc(21) = &H57565554: asc(22) = &H5B5A5958: asc(23) = &H5F5E5D5C asc(24) = &H63626160: asc(25) = &H67666564: asc(26) = &H6B6A6968 asc(27) = &H6F6E6D6C: asc(28) = &H73727170: asc(29) = &H77767574 asc(30) = &H7B7A7978: asc(31) = &H7F7E7D7C: asc(32) = &H83828180 asc(33) = &H87868584: asc(34) = &H8B8A8988: asc(35) = &H8F8E8D8C asc(36) = &H93929190: asc(37) = &H97969594: asc(38) = &H9B9A9998 asc(39) = &H9F9E9D9C: asc(40) = &HA3A2A1A0: asc(41) = &HA7A6A5A4 asc(42) = &HABAAA9A8: asc(43) = &HAFAEADAC: asc(44) = &HB3B2B1B0 asc(45) = &HB7B6B5B4: asc(46) = &HBBBAB9B8: asc(47) = &HBFBEBDBC asc(48) = &HC3C2C1C0: asc(49) = &HC7C6C5C4: asc(50) = &HCBCAC9C8 asc(51) = &HCFCECDCC: asc(52) = &HD3D2D1D0: asc(53) = &HD7D6D5D4 asc(54) = &HDBDAD9D8: asc(55) = &HDFDEDDDC: asc(56) = &HE3E2E1E0 asc(57) = &HE7E6E5E4: asc(58) = &HEBEAE9E8: asc(59) = &HEFEEEDEC asc(60) = &HF3F2F1F0: asc(61) = &HF7F6F5F4: asc(62) = &HFBFAF9F8 asc(63) = &HFFFEFDFC ' standard table std(0) = &H2010000: std(1) = &H6050403: std(2) = &H29282707 std(3) = &H9082B2A: std(4) = &HD0C0B0A: std(5) = &H11100F0E std(6) = &H15141312: std(7) = &H19181716: std(8) = &H2E2D2C25 std(9) = &H2031302F: std(10) = &H57343332: std(11) = &H37362135 std(12) = &H7B797772: std(13) = &H7F7E7D7C: std(14) = &H39388180 std(15) = &H3A5A5958: std(16) = &H9694833B: std(17) = &HABA89E9A std(18) = &HBBB9AFAD: std(19) = &HC5C1BFBD: std(20) = &HDCDAD8D6 std(21) = &HF2F0E6E1: std(22) = &H3CFCF6F4: std(23) = &H413F3E3D std(24) = &H96948342: std(25) = &HABA89E9A: std(26) = &HBBB9AFAD std(27) = &HC5C1BFBD: std(28) = &HDCDAD8D6: std(29) = &HF2F0E6E1 std(30) = &H43FCF6F4: std(31) = &H1A464544: std(32) = &HA9511B71 std(33) = &H6D6C6F54: std(34) = &H55DE7040: std(35) = &H1DFE1CD4 std(36) = &H52504F1E: std(37) = &H24236E53: std(38) = &H56DEE44E std(39) = &HFAFE1FD4: std(40) = &H61604726: std(41) = &H64486362 std(42) = &H5C846549: std(43) = &H4A672266: std(44) = &H7B795B68 std(45) = &H6B6A694B: std(46) = &H5DC6774C: std(47) = &H4D757473 std(48) = &H8E8A8688: std(49) = &H98929083: std(50) = &HA6A4A0A2 std(51) = &HB7B5B1B3: std(52) = &HC8CAC39C: std(53) = &H5EC5D0CC std(54) = &HECE8EAD2: std(55) = &HDCE3F8E6: std(56) = &H8E8A8688 std(57) = &H98929083: std(58) = &HA6A4A0A2: std(59) = &HB7B5B1B3 std(60) = &HC8CAC39C: std(61) = &H5FC5D0CC: std(62) = &HECE8EAD2 std(63) = &HFAE3F8E6 ' lexical table lex(0) = &H2010000: lex(1) = &H6050403: lex(2) = &H29282707 lex(3) = &H9082B2A: lex(4) = &HD0C0B0A: lex(5) = &H11100F0E lex(6) = &H15141312: lex(7) = &H19181716: lex(8) = &H2E2D2C25 lex(9) = &H2031302F: lex(10) = &H57343332: lex(11) = &H37362135 lex(12) = &H7A787672: lex(13) = &H7F7E7D7C: lex(14) = &H39388180 lex(15) = &H3A5A5958: lex(16) = &H9593823B: lex(17) = &HAAA79D99 lex(18) = &HBAB8AEAC: lex(19) = &HC4C0BEBC: lex(20) = &HDBD9D7D5 lex(21) = &HF1EFE5E0: lex(22) = &H3CFBF5F3: lex(23) = &H413F3E3D lex(24) = &H96948342: lex(25) = &HABA89E9A: lex(26) = &HBBB9AFAD lex(27) = &HC5C1BFBD: lex(28) = &HDCDAD8D6: lex(29) = &HF2F0E6E1 lex(30) = &H43FCF6F4: lex(31) = &H1A464544: lex(32) = &HA9511B71 lex(33) = &H6D6C6F54: lex(34) = &H55DD7040: lex(35) = &H1DFD1CD3 lex(36) = &H52504F1E: lex(37) = &H24236E53: lex(38) = &H56DEE44E lex(39) = &HF9FE1FD4: lex(40) = &H61604726: lex(41) = &H64486362 lex(42) = &H5C846549: lex(43) = &H4A672266: lex(44) = &H7B795B68 lex(45) = &H6B6A694B: lex(46) = &H5DC6774C: lex(47) = &H4D757473 lex(48) = &H8D898587: lex(49) = &H97918F8B: lex(50) = &HA5A39FA1 lex(51) = &HB6B4B0B2: lex(52) = &HC7C9C29B: lex(53) = &H5ECDCFCB lex(54) = &HEBE7E9D1: lex(55) = &HDFE2F7ED: lex(56) = &H8E8A8688 lex(57) = &H9892908C: lex(58) = &HA6A4A0A2: lex(59) = &HB7B5B1B3 lex(60) = &HC8CAC39C: lex(61) = &H5FCED0CC: lex(62) = &HECE8EAD2 lex(63) = &HFAE3F8EE End If ' ****************************************************************** Dim pTBL As Long Dim pREF As Long Dim tmp() As Long Dim cnt As Long On Error Resume Next Select Case flg And (srtLexical Or srtAscii) Case 0: pTBL = VarPtr(std(0)) Case srtLexical: pTBL = VarPtr(lex(0)) Case srtAscii: pTBL = VarPtr(asc(0)) Case srtUserDefChrMap: pTBL = tbl End Select cnt = UBound(arr) - LBound(arr) + 1 If pTBL = 0 Then arrSRT = -7 ElseIf cnt = 0 Then arrSRT = -6 Else If (flg And srtReferenceArr) Then ReDim tmp(LBound(arr) To UBound(arr)) pREF = VarPtr(tmp(LBound(tmp))) End If arrSRT = cdByVal( _ asm(0), _ VarPtr(arr), _ pREF, _ pTBL, _ flg And (srtDescending Or srtUnsigned)) If (flg And srtReferenceArr) Then ref = tmp End If End Function '---------- Ende Modul "Module1" alias Module1.bas ---------- '--------- Anfang Modul "Module2" alias Module2.bas --------- '------------------------------------------------------------- ' CPU-clock zum Messen kleiner Zeiten nutzen ' (benötigt einen Pentium-Prozessor!) ' ' (softKUS) - X/2003 '------------------------------------------------------------- Option Explicit Public clk_sec As Currency Public clk_dmy As Currency Private cur_txt As String ' Aufruf von asm-Funktionen (Deklaration für Longs) Private Declare Function cdLong _ Lib "user32" _ Alias "CallWindowProcA" _ (ByRef adr As Long, _ ByVal PA1 As Long, _ ByVal PA2 As Long, _ ByVal PA3 As Long, _ ByVal PA4 As Long) As Long Private Declare Function PCounter _ Lib "kernel32" _ Alias "QueryPerformanceCounter" _ (lpPerformanceCount As Currency) As Long Private Declare Function PFrequency _ Lib "kernel32" _ Alias "QueryPerformanceFrequency" _ (lpFrequency As Currency) As Long Private Declare Sub Sleep _ Lib "kernel32" _ (ByVal dwMilliSeconds As Long) ' clkDELAY Sleep-Funktion ' ' CALL: clkDELAY(D1:Delay, [N1:Interval], [C1:lpcDelay], [C2:lpcWait]) ' ' IN: dbl:D1 Wartezeit in sec ' lng:N1 =0: entspricht clkWAIT ' >0: periodischer Aufruf von sleep/DoEvents ' cur:C1 Platzhalter für loop-counter ' cur:C2 Platzhalter für clkWAIT-loop-counter ' Function clkDELAY( _ Delay As Double, _ Optional Interval As Long = 5, _ Optional lpcDelay As Currency, _ Optional lpcWait As Currency) As Double Dim cACT As Currency Dim cRUN As Currency Dim cEND As Currency Dim cCNT As Currency Dim cTMP As Currency clkINI lpcDelay = 0 lpcWait = 0 PFrequency cCNT PCounter cRUN cEND = cRUN + Delay * cCNT PCounter cACT If Interval > 0 Then cTMP = cEND - 0.02 * cCNT Do While cACT < cTMP lpcDelay = lpcDelay + 1 Sleep Interval DoEvents PCounter cACT Loop End If If cACT < cEND Then clkWAIT (cEND - cACT) / cCNT, lpcWait PCounter cACT clkDELAY = (cACT - cRUN) / cCNT End Function ' clkFMT Formatieren von Zeispannen ' ' AUFRUF: clkFMT(cur, [cnt]) ' ' EIN: cur:cur Zu formatierender Wert ' lng:cnt Anzahl Nachkommastellen (Vorgabe=2) ' ' AUS: chr Formatierter Text ' Function clkFMT( _ cur As Currency, _ Optional cnt As Long = 2) As String Dim sec As Double Dim txt As String txt = "0." & String(cnt, "0") If cur < 0 Then clkFMT = cur_txt ElseIf cur <> 0 Then If clk_sec Then sec = cur / clk_sec Select Case Log(sec) / Log(10) Case Is > 1 clkFMT = Format(sec / 60, txt) & " m" Case Is > -1 clkFMT = Format(sec, txt) & " s" Case Is > -4 clkFMT = Format(sec * 1000, txt) & " ms" Case Else clkFMT = Format(sec * 1000000, txt) & " µs" End Select End If End Function ' clkGET Einlesen des CPU-internen Taktzählers ' ' AUFRUF: clkGET(cur(), [NR]) ' ' EIN: cur:cur() Array von mind. 2 Currency-Werten ' lng:NR Zeiger auf cur()-Element (Vorgabe=0) ' ' AUS: cur(NR) Aktueller CPU-Taktzähler ' cur(NR+1) Differenz zw. aktuellem cur(NR) und ' cur(NR) beim Funktionsaufruf ' ' HINWEIS: Um Zeiten zu messen, sollte clkGET einmal zur Initiali- ' sierung aufgerufen werden (setzt cur(NR)) und ein weiteres ' mal zur Berechnung der Zeitspanne (setzt cur(NR+1)) ' Function clkGET( _ cur() As Currency, _ Optional NR As Long) As Currency Static asm(9) As Long If asm(0) = 0 Then asm(0) = &H4C8B310F: asm(1) = &H31FF0424 asm(2) = &H890471FF: asm(3) = &H4518901 asm(4) = &H424442B: asm(5) = &H8924141B asm(6) = &H51890841: asm(7) = &HF95A580C asm(8) = &H10C2C01B: asm(9) = &H0 End If ' ***************************************************** On Error Resume Next ' Fehler: ungültiges Array abfangen If UBound(cur) >= NR + 1 Then cdLong asm(0), VarPtr(cur(NR)), 0, 0, 0 clkGET = cur(NR + 1) End If End Function ' clkINI Initialisieren ' ' AUFRUF: clkINI([vl]) ' ' EIN: dbl:vl CheckRate (Vorgabe = 0.5) ' Erklärung s. unten ' ' AUS: cur Taktfrequenz ' ' setzt: clk_sec Anzahl Takte/Sekunde ' cur_txt Taktfrequenz als formatierter Text ' clk_dmy Durchschnittliche Anzahl Takte, die ' für clkGET() benötigt werden ' ' HINWEIS: CheckRate gibt in 1/sec die Zeitspanne an, ' die clkINI zwischen dem Lesen des CPU-Taktzählers ' verstreichen läßt. Je höher der Wert, desto genauer ' ist das Ergebnis (clk_sec/dur_dmy) ' Function clkINI(Optional chkRate As Double = 0.5) As Currency Dim cur(3) As Currency Dim cu1 As Currency Dim cu2 As Currency If clk_sec = 0 Then PFrequency cu1 PCounter cu2 cu1 = cu2 + cu1 * chkRate clkGET cur, 0 clkGET cur, 2 Do: PCounter cu2 clk_dmy = (clk_dmy + clkGET(cur, 2)) / 2 Loop Until cu2 >= cu1 clk_sec = clkGET(cur, 0) * (1 / chkRate) cu1 = IIf(clk_sec > 100000, 100000, 100) cur_txt = "Running at " & _ Format(clk_sec / cu1, "0.00") & _ IIf(cu1 = 100, " MHz", " GHz") End If clkINI = clk_sec End Function ' clkWAIT Sleep-Funktion ' ' AUFRUF: clkWAIT(Zeit, [cnt]) ' ' EIN: dbl:Zeit Abzuwartende Zeit in sec ' cur:Cnt Zähler ' ' AUS: dbl Tatsächlich verstrichene Zeit/sec ' cnt Anzahl der Loops der ASM-Funktion ' > 1: Ergebnis ist verläßlich ' ' HINWEIS: Die ASM-Funktion wird mit einem Array-Parameter ' aufgerufen: ' 0: CPU-Taktzähler beim Funktionsaufruf ' 1: Differenz 0/1 und aktueller CPU-Taktzähler ' 2: Anzahl Takte, die abgewartet werden soll ' 3: Loop-Zähler. Ist der Loop-Zähler nach Ver- ' lassen der Funktion >1, wurde die ASM-Schleife ' mehr als einmal durchlaufen und ist das Ergeb- ' nis verläßlich. Allerdings wird der Aufwand, ' der hier für den Funktionsaufruf betrieben wird, ' nicht berücksichtigt! ' Function clkWAIT(sec As Double, Optional cnt As Currency) As Double Static asm(12) As Long If asm(0) = 0 Then asm(0) = &H4C8B310F: asm(1) = &H1890424 asm(2) = &H33045189: asm(3) = &H184189C0 asm(4) = &HF1C4189: asm(5) = &H18418331 asm(6) = &H1C518301: asm(7) = &H1B012B00 asm(8) = &H41890451: asm(9) = &HC518908 asm(10) = &H1B10412B: asm(11) = &HE3721451 asm(12) = &H10C2 End If ' ***************************************************** Dim cur(3) As Currency cur(2) = Abs(sec) * clk_sec cdLong asm(0), VarPtr(cur(0)), 0, 0, 0 cnt = cur(3) clkWAIT = cur(1) / clk_sec End Function '---------- Ende Modul "Module2" alias Module2.bas ---------- '-------------- Ende Projektdatei Project1.vbp --------------
Tipp-Kompatibilität:
| Windows/VB-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
| VB4 |  |  | | | | | |
| VB5 | | | | | | |  |
| VB6 | | | | | | | |
Ihre Meinung
Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.
Archivierte Nutzerkommentare
Klicken Sie diesen Text an, wenn Sie die 4 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.
Kommentar von Udo Schmidt am 03.11.2007 um 22:02
Hallo, cf!
It's not a bug, it's a feature!
Klick mal "vorzeichenlos" an, dann sollten Bytes > 127 unten stehen.
Udo
Kommentar von cf am 03.11.2007 um 19:05
Ein Fehler:
http://img248.imageshack.us/img248/5012/fehlerzt0.png
Kommentar von Udo Schmidt am 26.12.2004 um 02:17
Sollte der Kommentator vom 21.12. noch einmal einen Blick hierauf werfen, fände ich es schön, wenn er seine Kritik etwas präzisierte.
Kommentar von am 21.12.2004 um 14:55
Affenscheiße