Kontakt
DSVGO
Historie | |
21.09.2001 | Unterscheidung von VB5 und VB6; |
19.01.2001 | Optimierung für kurze Suchstrings mittels API-Einsatz |
15.12.2000 | Erste Version |
Die folgende Funktion bestimmt die Anzahl der Vorkommen eines bestimmten Strings in einem Text. Optional kann für die Suche eine Startposition vorgegeben werden. Außerdem kann angegeben werden, ob Groß-/Kleinschreibung eine Rolle spielen soll.
Durch die Fall-Unterscheidung wird insbesondere bei kurzen Suchstrings eine deutliche Beschleunigung dadurch erreicht, dass Zeichen als Integer betrachtet werden. Der Vergleich von Ganzzahlen liegt VB nämlich deutlich mehr.
Im Deklarationsteil sind folgende API-Funktionen zu deklarieren (man beachte, dass unter VB5 msvbvm50.dll benutzt werden muss, unter VB6 dagegen msvbvm60.dll):
Public Declare Function ArrPtr Lib "msvbvm50.dll" _ Alias "VarPtr" (Ptr() As Any) As Long '<-- VB5 Public Declare Function ArrPtr Lib "msvbvm60.dll" _ Alias "VarPtr" (Ptr() As Any) As Long '<-- VB6 Public Declare Sub RtlMoveMemory Lib "kernel32" ( _ dest As Any, source As Any, ByVal bytes As Long)
Die eigentliche Arbeit macht die folgende Funktion. Nach dem Check auf den Vergleichs-Modus genügt immer der binäre Vergleich (!). Ein erster Treffer wird konventionell (mit InStrB) gesucht. Die nächsten Treffer werden entweder ebenfalls mit InStrB gesucht (das ist der "langweilige" Fall, wenn das Suchwort mehr als 8 Zeichen enthält), oder mit einer Folge von Integer-Vergleichen (bei kurzen Suchwörten, was wohl der Normalfall ist).
Public Static Function StrCount( _ ByRef Text As String, _ ByRef Find As String, _ Optional ByVal Start As Long = 1, _ Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _ ) As Long Const MODEMARGIN = 8 Dim TextAsc() As Integer Dim TextData As Long Dim TextPtr As Long Dim FindAsc(0 To MODEMARGIN) As Integer Dim FindLen As Long Dim FindChar1 As Integer Dim FindChar2 As Integer Dim i As Long If Compare = vbBinaryCompare Then FindLen = Len(Find) If FindLen Then 'Ersten Treffer bestimmen: If Start < 2 Then Start = InStrB(Text, Find) Else Start = InStrB(Start + Start - 1, Text, Find) End If If Start Then StrCount = 1 If FindLen <= MODEMARGIN Then If TextPtr = 0 Then 'TextAsc-Array vorbereiten: ReDim TextAsc(1 To 1) TextData = VarPtr(TextAsc(1)) RtlMoveMemory TextPtr, ByVal ArrPtr(TextAsc), 4 TextPtr = TextPtr + 12 End If 'TextAsc-Array initialisieren: RtlMoveMemory ByVal TextPtr, ByVal VarPtr(Text), 4 'pvData RtlMoveMemory ByVal TextPtr + 4, Len(Text), 4 'nElements Select Case FindLen Case 1 'Das Zeichen buffern: FindChar1 = AscW(Find) 'Zählen: For Start = Start \ 2 + 2 To Len(Text) If TextAsc(Start) = FindChar1 Then StrCount = StrCount + 1 Next Start Case 2 'Beide Zeichen buffern: FindChar1 = AscW(Find) FindChar2 = AscW(Right$(Find, 1)) 'Zählen: For Start = Start \ 2 + 3 To Len(Text) - 1 If TextAsc(Start) = FindChar1 Then If TextAsc(Start + 1) = FindChar2 Then StrCount = StrCount + 1 Start = Start + 1 End If End If Next Start Case Else 'FindAsc-Array füllen: RtlMoveMemory ByVal VarPtr(FindAsc(0)), ByVal StrPtr(Find), FindLen + FindLen FindLen = FindLen - 1 'Die ersten beiden Zeichen buffern: FindChar1 = FindAsc(0) FindChar2 = FindAsc(1) 'Zählen: For Start = Start \ 2 + 2 + FindLen To Len(Text) - FindLen If TextAsc(Start) = FindChar1 Then If TextAsc(Start + 1) = FindChar2 Then For i = 2 To FindLen If TextAsc(Start + i) <> FindAsc(i) Then Exit For Next i If i > FindLen Then StrCount = StrCount + 1 Start = Start + FindLen End If End If End If Next Start End Select 'TextAsc-Array restaurieren: RtlMoveMemory ByVal TextPtr, TextData, 4 'pvData RtlMoveMemory ByVal TextPtr + 4, 1&, 4 'nElements Else 'Konventionell Zählen: FindLen = FindLen + FindLen Start = InStrB(Start + FindLen, Text, Find) Do While Start StrCount = StrCount + 1 Start = InStrB(Start + FindLen, Text, Find) Loop End If 'FindLen <= MODEMARGIN End If 'Start End If 'FindLen Else 'Groß-/Kleinschreibung ignorieren: StrCount = StrCount(LCase$(Text), LCase$(Find), Start) End If End Function
Man beachte, dass aus Performance-Gründen InStrB und LenB benutzt werden.
© Jost Schwider, 15.12.2000-21.09.2001 - http://vb-tec.de/strcount.htm