Attribute VB_Name = "CountWordsInString"
Option Explicit
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)

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