VBspeed / String / InStrCount
VBspeed © 2000-10, updated: 05-Oct-2002
InStrCount


The Definition
Function InStrCount
Returns the count of substrings found within a given string.
Declaration:
InStrCount(String1, String2[, Start[, Compare]])
Arguments:
String1Required. String expression containing substring to count.
If String1 is zero-length, InStrCount returns 0.
String2Required. Substring being counted.
If String2 is zero-length, InStrCount returns 0.
StartOptional. Position within String1 where substring search is to begin.
If omitted, 1 is assumed.
CompareOptional. Numeric value indicating the kind of comparison to use when evaluating substrings.
If omitted, the default value is 0, which means perform a binary comparison.
Remarks:
Note that, in analogy to Replace, InStrCount("aaaa","aa") returns 2 (not 3).
Use this function (VB5/6-compatible) to verify the correctness of your code.


The Charts
Calls
 lRet = InStrCount(String1, String2, , Compare)
Call 1 String1 = Replicate(1000, "abcd")
String2 = "b"
Compare = vbBinaryCompare
Call 2 String1 = Replicate(1000, "abcd")
String2 = "B"
Compare = vbTextCompare
Call 3 String1 = Replicate(1000, "abcd")
String2 = "bc"
Compare = vbBinaryCompare
Call 4 String1 = Replicate(1000, "abcd")
String2 = "BC"
Compare = vbTextCompare
Call 5 String1 = Replicate(100, "The quick brown fox jumped over the lazy dogs")
String2 = "jumped over"
Compare = vbBinaryCompare
Call 6 String1 = Replicate(100, "The Quick Brown Fox Jumped Over The Lazy Dogs")
String2 = "jumped over"
Compare = vbTextCompare
 VB5
CodeAuthorDopingNotes
InStrCount01 Donald  
InStrCount02 Jost  
InStrCount03 PeterNierop  
InStrCount04 JostAPI 
InStrCount05 GuyAPI 
InStrCount06 MarzoAPI 
InStrCount07 MarzoAPI 
Call 1
67.4170s
56.8065s
X1.9418s
32.0920s
44.4042s
21.2712s
11.0010s
Call 2
64,720.3264,880s
58.36115s
X1.7123s
45.1370s
34.5162s
21.1115s
11.0014s
Call 3
64.3576s
53.9569s
X1.6228s
11.0017s
41.7530s
21.1821s
31.1921s
Call 4
62,380.8464,938s
54.35119s
X1.1632s
42.4868s
31.5943s
11.0027s
21.0027s
Call 5
11.0013s
21.0914s
X2.5332s
31.1014s
41.2616s
51.5720s
61.7422s
Call 6
6295.277,401s
42.8070s
X1.4035s
52.8070s
11.0025s
21.1027s
31.1128s
 VB6
CodeAuthorDopingNotes
InStrCount01 Donald  
InStrCount02 Jost  
InStrCount03 PeterNierop  
InStrCount04 JostAPI 
InStrCount05 GuyAPI 
InStrCount06 MarzoAPI 
InStrCount07 MarzoAPI 
Call 1
65.0861s
54.7858s
X1.7021s
31.6420s
43.5943s
11.0012s
21.0112s
Call 2
64,410.4465,070s
57.36109s
X1.6825s
44.8071s
34.7570s
21.1717s
11.0015s
Call 3
64.0566s
53.6960s
X1.7328s
11.0016s
41.8731s
31.2020s
21.1519s
Call 4
62,510.7064,942s
54.30111s
X1.2432s
42.5967s
31.9250s
21.2031s
11.0026s
Call 5
11.0014s
21.2116s
X2.4333s
31.2216s
41.2116s
61.7123s
51.5020s
Call 6
6274.417,390s
42.7373s
X1.3937s
52.7373s
21.0729s
31.2734s
11.0027s
Conclusions
A pretty fuzzy scene ... InStrCount06/07 is probably your choice when you compare textwise, InStrCount01 definitely isn't.
Note the differences between VB5 and VB6 when you compare InStrCount06 with InStrCount07.

* Note that InStrCount03 is fast but incorrect with (a) non-ASCII strings, and (b) in text compare mode. Use with care.
Mail your code! How to read all those numbers


The Code
InStrCount01
submitted 23-Sep-2000 by Donald Lessau  
Doping: none
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
Author's comments:
Donald's comments:

top | charts


InStrCount02
submitted 15-Dec-2000 by Jost Schwider    vb-tec.de
Doping: none
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
      
      'Zhlen:
      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
Author's comments:
Donald's comments:

top | charts


InStrCount03
submitted 26-Dec-2000 by Peter Nierop  
Doping: none
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
Author's comments:
Donald's comments:

top | charts


InStrCount04
submitted 15-Jan-2001 by Jost Schwider    vb-tec.de
(added 20010912)
Doping: API
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)

            'Zhlen:
            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))

            'Zhlen:
            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 fllen:
            RtlMoveMemory ByVal VarPtr(FindAsc(0)), ByVal StrPtr(Find), FindLen + FindLen
            FindLen = FindLen - 1

            'Die ersten beiden Zeichen buffern:
            FindChar1 = FindAsc(0)
            FindChar2 = FindAsc(1)

            'Zhlen:
            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 Zhlen:
          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
Author's comments:
Donald's comments:

top | charts


InStrCount05
submitted 20-Nov-2001 by Guy Gervais  
Doping: API (cf. Dope'n'Declarations)
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
Author's comments: uses a Boyer-Moore string search algorithm, which has a short set-up phase. So for short strings, it is not as fast as some other algorithms.
Donald's comments:

top | charts


InStrCount06
submitted 05-Oct-2002 by Marzo Junior  
Doping: API (cf. Dope'n'Declarations)
Class-wrapped. The class, which also includes a bunch of related functions, is waiting for you here.
Author's comments:
Donald's comments:

top | charts


InStrCount07
submitted 06-Oct-2002 by Marzo Junior  
Doping: API (cf. Dope'n'Declarations)
Class-wrapped. The class, which also includes a bunch of related functions, is waiting for you here.
Author's comments:
Donald's comments:

top | charts




VBspeed © 2000-10 by Donald Lessau