Public Function InStrCount01( _
                              String1 As String, _
                              String2 As String, _
               Optional ByVal Start As Long = 1, _
                     Optional Compare As VbCompareMethod = vbBinaryCompare) As Long

' by Donald, donald@xbeat.net, 20000923
  Dim lenFind As Long

  lenFind = Len(String2)
  
  If lenFind Then
    ' silently correct illegal Start value
    If Start < 1 Then
      Start = 1
    End If
    Do
      Start = InStr(Start, String1, String2, Compare)
      If Start Then
        InStrCount01 = InStrCount01 + 1
        Start = Start + lenFind
      Else
        Exit Function
      End If
    Loop
  End If

End Function

Public Function InStrCount02( _
    ByRef String1 As String, _
    ByRef String2 As String, _
    Optional ByVal Start As Long = 1, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _
  ) As Long
' by Jost Schwider, jost@schwider.de, 20001215
  Dim Length2 As Long
  
  If Compare = vbBinaryCompare Then
    Length2 = LenB(String2)
    If Length2 Then
      'Startwert "normieren":
      If Start < 2 Then
        Start = InStrB(String1, String2)
      Else
        Start = InStrB(Start + Start - 1, String1, String2)
      End If
      
      'Zählen:
      Do While Start
        InStrCount02 = InStrCount02 + 1
        Start = InStrB(Start + Length2, String1, String2)
      Loop
    End If
  Else
    InStrCount02 = InStrCount02(LCase$(String1), LCase$(String2), Start)
  End If
End Function

Public Function InStrCount03( _
                Expression As String, _
                Find As String, _
                Optional Start As Long = 1, _
                Optional Compare As VbCompareMethod = vbBinaryCompare _
                ) As Long

' by Peter Nierop, pnierop.pnc@inter.nl.net, 20001226

  Dim aOrg() As Byte, lMaxOrg&, lCurOrg&
  Dim aFind() As Byte, lMaxFind&, lCurFind&, lFind&, lComp&

  Dim lFindCount&

  '=========== check op input ========================================
  lMaxOrg = Len(Expression)
  lMaxFind = Len(Find)


  ' preload the first character to find
  If lMaxOrg = 0 Or lMaxFind = 0 Or Start > lMaxOrg Then
    InStrCount03 = 0
    Exit Function
  End If

  If Start < 1 Then
    Err.Raise 5, "InStrCount Function", "Start can't be smaller than 1"
    Exit Function
  ElseIf Start > 1 Then
    lCurOrg = Start * 2 - 2
  End If



  '=========== prepare buffers =======================================
  aOrg = Expression
  lMaxOrg = UBound(aOrg)



  '==========  With one character to find -> shorter loop =====================
  If lMaxFind = 1 Then

    lFind = Asc(Find)
    If Compare = vbBinaryCompare Then
      For lCurOrg = lCurOrg To lMaxOrg Step 2

        If lFind = aOrg(lCurOrg) Then
          lFindCount = lFindCount + 1
        End If

      Next

    Else
      lComp = &HDF   'to uppercase
      lFind = lFind And lComp

      For lCurOrg = lCurOrg To lMaxOrg Step 2

        If lFind = (aOrg(lCurOrg) And lComp) Then
          lFindCount = lFindCount + 1
        End If

      Next
    End If

  Else
  '============ Longer loop if multiple characters to find ======================

    aFind = Find
    lMaxFind = UBound(aFind)
    lFind = aFind(0)

    If Compare = vbBinaryCompare Then
      For lCurOrg = lCurOrg To lMaxOrg Step 2

        If lFind = aOrg(lCurOrg) Then

          lCurFind = lCurFind + 2
          ' if no more characters to test -> match with string happened
          If lCurFind >= lMaxFind Then
            lFindCount = lFindCount + 1
            lCurFind = 0  'and start over
          End If
          ' now load next character from string to find
          lFind = aFind(lCurFind)

        Else
          ' no match so back to next character after first match
          lCurOrg = lCurOrg - lCurFind
          lCurFind = 0
          lFind = aFind(0)
        End If

      Next

    Else

      ' modify find array to uppercase
      For lCurFind = 0 To lMaxFind Step 2
        aFind(lCurFind) = aFind(lCurFind) And &HDF
      Next
      lCurFind = 0
      lFind = aFind(0)
      lComp = &HDF

      For lCurOrg = lCurOrg To lMaxOrg Step 2

        If lFind = (aOrg(lCurOrg) And lComp) Then

          lCurFind = lCurFind + 2
          ' if no more characters to test -> match with string happened
          If lCurFind >= lMaxFind Then
            lFindCount = lFindCount + 1
            lCurFind = 0  'and start over
          End If
          ' now load next character from string to find
          lFind = aFind(lCurFind)

        Else
          ' no match so back to next character after first match
          lCurOrg = lCurOrg - lCurFind
          lCurFind = 0
          lFind = aFind(0)
        End If

      Next

    End If

  End If

  InStrCount03 = lFindCount
End Function

Public Static Function InStrCount04( _
    ByRef Text As String, _
    ByRef Find As String, _
    Optional ByVal Start As Long = 1, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _
  ) As Long
' by Jost Schwider, jost@schwider.de, 20010912, rev 001 20011121
  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
        InStrCount04 = 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 InStrCount04 = InStrCount04 + 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
                  InStrCount04 = InStrCount04 + 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
                    InStrCount04 = InStrCount04 + 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
            InStrCount04 = InStrCount04 + 1
            Start = InStrB(Start + FindLen, Text, Find)
          Loop

        End If 'FindLen <= MODEMARGIN
      End If 'Start
    End If 'FindLen
  Else
    'Groß-/Kleinschreibung ignorieren:
    InStrCount04 = InStrCount04(LCase$(Text), LCase$(Find), Start)
  End If
End Function

Public Function InStrCount05( _
    ByRef Text As String, _
    ByVal Target As String, _
    Optional Start As Long = -1, _
    Optional Compare As VbCompareMethod = vbBinaryCompare _
  ) As Long
' By Guy Gervais, ggervais@videotron.ca, 19 Nov 2001

Dim Skip(0 To 255)  As Long     ' Array containing number of positions to advance when comparison mismatch

Dim iText()         As Integer  ' Will contain our string data
Dim iTarget()       As Integer

Dim SAText          As SafeArray1D
Dim SATarget        As SafeArray1D

Dim ilTx            As Long     ' Len of Text
Dim ilTg            As Long     ' Len of Target
Dim iUBTG           As Long     ' Ubound of Target
Dim iPos            As Long     ' Position in the text which we're currently comparing
Dim iJmp            As Long     ' Numbers of position to advance for our next comparison
Dim iChk            As Long     ' Counter for the full target check
Dim fMatch          As Boolean  ' In case-sensitive search, indicates a match between the position and the target's tail
Dim fNoMatch        As Boolean  ' When checking for a complete match, indicates a mismatch somewhere in the text

Dim i               As Long     ' loop counter
Dim tmp             As Long     ' caches a repetetive calculation in a loop

    
    ' Init
    ilTx = Len(Text)
    ilTg = Len(Target)
    
    If ilTg = 0 Then Exit Function
    
    ' Map Integer arrays to strings
    With SAText
        .cDims = 1
        .cbElements = 2&
        .cElements = ilTx
        .fFeatures = FADF_AUTO Or FADF_FIXEDSIZE
        .pvData = StrPtr(Text)
    End With
    CopyMemory ByVal VarPtrArray(iText), VarPtr(SAText), 4&
    
    With SATarget
        .cDims = 1
        .cbElements = 2&
        .cElements = ilTg
        .fFeatures = FADF_AUTO Or FADF_FIXEDSIZE
        .pvData = StrPtr(Target)
    End With
    CopyMemory ByVal VarPtrArray(iTarget), VarPtr(SATarget), 4&
    
    iUBTG = UBound(iTarget)

    ' Convert the target to uppercase if necessary
    If Compare Then
        For i = 0 To iUBTG
            Select Case iTarget(i)
                Case 97 To 122, 224 To 246, 248 To 254
                    iTarget(i) = iTarget(i) And 223&
            End Select
        Next
    End If

    ' Prime the Skip array
    For i = 0 To iUBTG - 1
        Skip(iTarget(i)) = iUBTG - i
    Next
        
    ' Init all chars not in Target
    For i = 0 To 255
        If Skip(i) = 0 Then Skip(i) = ilTg
    Next

    ' Start the search
    If Start > 0 Then
        iPos = Start + iUBTG - 1
    Else
        iPos = iUBTG
    End If
    
    If Compare Then
        
        ' Text Compare
        Do While iPos < ilTx
            Select Case (iText(iPos))
                Case 97 To 122, 224 To 246, 248 To 254
                    iJmp = Skip(iText(iPos) And 223&)
                    fMatch = ((iText(iPos) And 223&) = iTarget(iUBTG))
                Case Else
                    iJmp = Skip(iText(iPos))
                    fMatch = (iText(iPos) = iTarget(iUBTG))
            End Select
            
            If fMatch Then
                fNoMatch = False
                tmp = iPos - iUBTG
                For iChk = iUBTG - 1 To 0& Step -1
                    Select Case iTarget(iChk)
                        Case 65 To 90, 192 To 214, 216 To 222
                            ' Compare as uppercase
                            If iTarget(iChk) <> (iText(tmp + iChk) And 223&) Then
                                fNoMatch = True
                                Exit For
                            End If
                        Case Else
                            ' Same as binary compare
                            If iTarget(iChk) <> iText(tmp + iChk) Then
                                fNoMatch = True
                                Exit For
                            End If
                    End Select
                Next
                If fNoMatch Then
                    Select Case iText(iPos)
                        Case 97 To 122, 224 To 246, 249 To 253
                            ' iJmp previously calculated
                        Case Else
                            iJmp = Skip(iText(iPos))
                    End Select
                Else
                    InStrCount05 = InStrCount05 + 1&
                    iJmp = ilTg
                End If
            End If
            iPos = iPos + iJmp
        Loop
    
    Else
        
        ' Binary Compare
        Do While iPos < ilTx
            If iText(iPos) = iTarget(iUBTG) Then
                fNoMatch = False
                tmp = iPos - iUBTG
                For iChk = iUBTG - 1& To 0& Step -1
                    If iTarget(iChk) <> iText(tmp + iChk) Then
                        fNoMatch = True
                        Exit For
                    End If
                Next
                If fNoMatch Then
                    iJmp = Skip(iText(iPos))
                Else
                    InStrCount05 = InStrCount05 + 1&
                    iJmp = ilTg
                End If
            Else
                iJmp = Skip(iText(iPos))
            End If
            iPos = iPos + iJmp
        Loop
    
    End If
    
    ' Clean up
    CopyMemory ByVal VarPtrArray(iTarget), 0&, 4&
    CopyMemory ByVal VarPtrArray(iText), 0&, 4&
    
End Function