VB-Tec.de Visual Basic - Technik, FAQ, Tricks, Beispiele

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

Beschreibung

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.

Code / Quelltext

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.