instr Count

Hi,

I've got a basic instr count function, can anyone see any flaws in it or any way of tweaking it to make it more efficient without making api calls etc.

VB Code:

Private Sub Command1_Click()
    Debug.Print InStrCount("the quick brown fox jumped over the lazy dog", " ") & vbNewLine
End Sub
 
Private Function InStrCount(ByVal Expression As String, _
                        ByVal Find As String, _
                        Optional ByVal Start As Long = 1, _
                        Optional ByVal Count As Long = -1, _
                        Optional Compare As VbCompareMethod = vbBinaryCompare) As Long
    Dim Temp$, h As Long
    On Error Resume Next ' handle div by zero
    Temp$ = Replace(Expression, Find, "", Start, Count, Compare)
    h = CLng(LenB(Expression) - LenB(Temp$))
    h = CLng(h \ LenB(Find))
    InStrCount = h
End Function

Any help or pointers will be gratefully received

Cheers Al

That's not terribly efficient, you want the data that you are searching to be constant, as in, you don't want it to change. If the string is passed by a reference as opposed to by value, a new copy of the string won't have to be made, making it more efficient for longer strings.

Also, you don't want to use the On Error Resume Next statement. If that is purely to avoid a division by zero, you should check for a zero length string before trying to complete the entire subroutine.

I'm not too sure, but see if Replace() also has a Replace$() equivalent. The difference between the two being that Replace() returns a variant (which later is converted back to a string), but the Replace$() version returns a string.

DreamLax,

Thanks for the tips here is the updated function -

VB Code:

Private Function InstrCount(ByVal Expression As String, _
                        ByVal Find As String, _
                        Optional ByVal Start As Long = 1, _
                        Optional Compare As VbCompareMethod = vbBinaryCompare) As Long
                        
    Dim Temp$, h As Long
    If LenB(Find) Then    ' check for zero length find; avoid div by zero
        Temp$ = Replace$(Expression, Find, "", Start, -1, Compare)
        h = CLng(LenB(Expression) - LenB(Temp$))
        h = CLng(h \ LenB(Find))
    End If
    InstrCount = h
End Function

Regards Allan

Hi,

I forgot to change the byVal's to byRef.

I've also put the "h" assignment onto one line to avoid two calls to clng.

I've read that Division is very slow. Does anyone know if there is a way of converting into a decimal so that I can multiply rather, I've hi-lited the spot in question

VB Code:

Private Function InstrCount(ByRef Expression As String, _
                        ByRef Find As String, _
                        Optional ByRef Start As Long = 1, _
                        Optional Compare As VbCompareMethod = vbBinaryCompare) As Long
                        
    Dim Temp$, h As Long
    If LenB(Find) Then    ' check for zero length find; avoid div by zero
        Temp$ = Replace$(Expression, Find, "", Start, -1, Compare)
        h = CLng((LenB(Expression) - LenB(Temp$)) [HL="#FFFF00"]/ LenB(Find)[/HL])
    End If
    InstrCount = h
End Function

Cheers Al

Here this was about as fast as I could get it :)

VB Code:

Private Function InStrCount(ByRef Expression As String, _
                            ByRef Find As String, _
                            Optional ByVal Start As Long = 1, _
                            Optional Compare As VbCompareMethod = vbBinaryCompare) _
                           As Long
    Dim Temp$
    If (LenB(Find)) Then
        Temp$ = Replace$(Expression, Find, vbNullString, Start, -1, Compare)
        InStrCount = CLng((LenB(Expression) - LenB(Temp$)) \ LenB(Find))
    End If
End Function

Nice one Penagate, thanks a bunch!

Handling strings is slow -> Replace$ is slow. Original InStr is VERY fast. InStrB is even a bit faster (as far as I remember).

VB Code:

Private Function InStrCount(ByRef Expression As String, _
                            ByRef Find As String, _
                            Optional ByVal Start As Long = 1, _
                            Optional Compare As VbCompareMethod = vbBinaryCompare) _
                            As Long
    Dim Position As Long, Count As Long
    Position = InStrB(Start, Expression, Find, Compare)
    Do While Position > 0
        Count = Count + 1
        Position = InStrB(Position + 2, Expression, Find, Compare)
    Loop
    InStrCount = Count
End Function

Merri,

Thanks for the function unfortunately it doesn't work correctly. I've tested it using the below functions, however I get the idea

Cheers Al

VB Code:

Public Function IsGoodInStrCount(Optional fLigaturesToo As Boolean) As Boolean
' verify correct InStrCount returns, 20021005
' returns True if all tests are passed
  
  ' replace "InStrCount" with the name of your function to test
  Dim fFailed As Boolean
  Dim Text As String
  
  If InStrCount("ababa", "a") <> 3 Then Stop: fFailed = True
  If InStrCount("ababa", "ab") <> 2 Then Stop: fFailed = True
  If InStrCount("ababa", "aba") <> 1 Then Stop: fFailed = True
  If InStrCount("ababa", "abb") <> 0 Then Stop: fFailed = True
  If InStrCount("ababa", "") <> 0 Then Stop: fFailed = True
  If InStrCount("", "a") <> 0 Then Stop: fFailed = True
  If InStrCount("aaaa", "aa") <> 2 Then Stop: fFailed = True
  
  If InStrCount("aAaA", "a") <> 2 Then Stop: fFailed = True
  If InStrCount("aAaA", "a", , vbTextCompare) <> 4 Then Stop: fFailed = True
  If InStrCount("aAaA", "A", , vbTextCompare) <> 4 Then Stop: fFailed = True
 
  ' unicode
  If InStrCount("€€€", "€") <> 3 Then Stop: fFailed = True
  If InStrCount("[a]{a}", "{A}", , vbTextCompare) <> 1 Then Stop: fFailed = True
  
  ' Common chars when parsing Unix "man" pages...
  Text = Replicate05(10, "{|}[/][\]{{||}}[/][\]{{{|||}}}[/][\]")
  If InStrCount(Text, "{|}", , vbTextCompare) <> 10 Then Stop: fFailed = True
  
  ' the 4 stooges: š/Š, œ/Œ, ž/Ž, ÿ/Ÿ (154/138, 156/140, 158/142, 255/159)
  If InStrCount("Hašiš", "Š", , vbTextCompare) <> 2 Then Stop: fFailed = True
  ' ligatures  textcompare (VBspeed entries do NOT have to pass this test)
  If fLigaturesToo Then
    ' ligatures, a digraphemic fun house: ss/ß, ae/æ, oe/œ, th/þ
    If InStrCount("Straße", "ss", , vbTextCompare) <> 1 Then Stop: fFailed = True
  End If
    
  ' well done
  IsGoodInStrCount = Not fFailed
  
End Function
 
Public Function Replicate05(ByVal Number&, Pattern$) As String
' by Donald, [email][email protected][/email], 20001206, rev 002
' based on Replicate03 by Larry Serflaten, [email][email protected][/email], 20001206
 
  Dim LP As Long
  
  If Number > 0 Then
    LP = Len(Pattern)
    Select Case LP
    Case Is > 1
      Replicate05 = Space$(Number * LP)
      Mid$(Replicate05, 1, LP) = Pattern
      If Number > 1 Then
        Mid$(Replicate05, LP + 1) = Replicate05
      End If
    Case 1
      Replicate05 = String$(Number, Pattern)
    End Select
  End If
  
End Function

VB Code:

Private Function InStrCount(ByRef Expression As String, _
                            ByRef Find As String, _
                            Optional ByVal Start As Long = 1, _
                            Optional Compare As VbCompareMethod = vbBinaryCompare) _
                            As Long
    Dim Position As Long, Count As Long, Length As Long
    Length = Len(Find)
    If Length > 0 Then
        Position = InStr(Start, Expression, Find, Compare)
        Do While Position > 0
            Count = Count + 1
            Position = InStr(Position + Length, Expression, Find, Compare)
        Loop
        InStrCount = Count
    End If
End Function

InStrB doesn't like TextCompare.

Merri,

That's spot on! I've tested the speed and these are the results

my function -

Call1: 1000 Time: 1.129
Call2: 1000 Time: 1.157
Call3: 1000 Time: 1.057
Call4: 1000 Time: 1.896
Call5: 100 Time: 0.192
Call6: 100 Time: 0.213

your function -

Call1: 1000 Time: 0.27
Call2: 1000 Time: 51.79
Call3: 1000 Time: 0.27
Call4: 1000 Time: 52.9
Call5: 100 Time: 0.04
Call6: 100 Time: 6.18

test details -
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

As is so often the case with these things it's 6 of one and half a dozen of the other :afrog:

In which case we combine the good things:

VB Code:

Private Function InStrCount(ByRef Expression As String, _
                            ByRef Find As String, _
                            Optional ByVal Start As Long = 1, _
                            Optional Compare As VbCompareMethod = vbBinaryCompare) _
                            As Long
    Dim Position As Long, Count As Long, Length As Long, Temp As String
    Length = CLng(LenB(Find))
    If Length > 0 Then
        If Compare = vbBinaryCompare Then
            Position = InStrB(Start, Expression, Find, Compare)
            Do While Position > 0
                Count = Count + 1
                Position = InStrB(Position + Length, Expression, Find, vbBinaryCompare)
            Loop
            InStrCount = Count
        Else
            Temp = Replace$(Expression, Find, vbNullString, Start, -1, Compare)
            InStrCount = CLng(LenB(Expression) - LenB(Temp)) \ Length
        End If
    End If
End Function

And then they lived happily ever after.

Nice one Merri, thanks for all your help

Cheers Al

Out of interest: did you make a comparison with old codes vs. the final result?

Merri,

My original test was done on my home PC, these were done at work. Here you go -

Your Hybrid function -
^{Call1: 1000 Time: 0.27
Call2: 1000 Time: 0.82
Call3: 1000 Time: 0.25
Call4: 1000 Time: 0.69
Call5: 100 Time: 0.04
Call6: 100 Time: 0.17}

Your Original -
^{Call1: 1000 Time: 0.308
Call2: 1000 Time: 55.341
Call3: 1000 Time: 0.325
Call4: 1000 Time: 57.292
Call5: 100 Time: 0.039
Call6: 100 Time: 6.293}

My Original -
^{Call1: 1000 Time: 0.66
Call2: 1000 Time: 0.671
Call3: 1000 Time: 0.598
Call4: 1000 Time: 0.659
Call5: 100 Time: 0.075
Call6: 100 Time: 0.142}


Since your function is a hybrid I can only think that the reason it doesn't win all tests is because there are more lines of code to process in the hybrid function, they're very tightly run so the hyrid is the way forward.

Cheers Al :D

Yeah, extra comparisons cause minor drawback; atleast LenB can be proven to be faster than InStr :)

I don't know if you did a complete benchmark or not; are these one run only or avarage on multiple runs? Not that it matters too much, it is fast enough as it is :)

Merri,

Just one run comparisons

Cheers Al

Merri,

On another topic I just noticed in your signature your postings on PSC which I've checked out and I'm interested in your InBArr and InBArrRev functions I've downloaded it but am getting load errors with frmTest -

Taken from frmTest.log
Line 17: Property ItemData in Combo1 had an invalid file reference.
Line 19: Property List in Combo1 had an invalid file reference.

What references do I need? microsoft windows common controls?

Plus getting invalid property value error in -

VB Code:

Private Sub Form_Load()
    [HL="#FFFF00"]Combo1.ListIndex = 0[/HL]    
    TestFile = "c:\autoexec.bat"
    KeyWord = "select"
    Iterations = 100000
End Sub

Any ideas?

Cheers Al

There just should be two items items in the ComboBox, I can't remember what it says in them as I'm not in the computer where I have the source. Just add two items to the combobox (like, 1 and 2) and try if it works then.

Yar thanks I've sorted it, added in all the compare options manually.

I'm just knocking out an email to you via PSC. Rather than posting off topic here. Don't want to offend anyone :)

Cheers Al

Here is a new version of InBArr.

Code:

---

Option Explicit
Public Function InBArr(ByRef ByteArray() As Byte, ByRef KeyWord As String, Optional StartPos As Long = 0, Optional Compare As Byte = vbBinaryCompare, Optional IsUnicode As Boolean = True) As Long
    Static KeyBuffer() As Byte, KeyBufferU() As Byte
    Dim A As Long, B As Long, C As Long, KeyLen As Long, KeyUpper As Long
    Dim FirstKeyByte As Byte, LastKeyByte As Byte, TempByte As Byte
    Dim FirstKeyByte2 As Byte, LastKeyByte2 As Byte, TempByte2 As Byte
    Dim FirstKeyByteU As Byte, LastKeyByteU As Byte
    Dim FirstKeyByte2U As Byte, LastKeyByte2U As Byte
    If (Not ByteArray) = True Then InBArr = -1: Exit Function
    If LenB(KeyWord) = 0 Then InBArr = StartPos: Exit Function
    If Compare = vbBinaryCompare Then
        KeyBuffer = KeyWord
    Else
        KeyBufferU = UCase$(KeyWord)
        KeyBuffer = LCase$(KeyWord)
    End If
    KeyLen = UBound(KeyBuffer) - 1
    KeyUpper = KeyLen \ 2
    If KeyUpper > UBound(ByteArray) Then InBArr = -1: Exit Function
    If StartPos < 0 Then StartPos = 0
    If IsUnicode Then
        If (StartPos Mod 2) = 1 Then StartPos = StartPos - (StartPos Mod 2) + 2
        If StartPos > UBound(ByteArray) - KeyLen Then StartPos = UBound(ByteArray) - KeyLen
        FirstKeyByte = KeyBuffer(0)
        LastKeyByte = KeyBuffer(KeyLen)
        FirstKeyByte2 = KeyBuffer(1)
        LastKeyByte2 = KeyBuffer(KeyLen + 1)
        If Compare = vbBinaryCompare Then
            'loop through the array
            For A = StartPos To UBound(ByteArray) - KeyLen - 1 Step 2
                If ByteArray(A) = FirstKeyByte And ByteArray(A + 1) = FirstKeyByte2 Then
                    If ByteArray(A + KeyLen) = LastKeyByte And ByteArray(A + KeyLen + 1) = LastKeyByte2 Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 2
                            For B = 2 To KeyLen - 1 Step 2
                                If Not (ByteArray(C) = KeyBuffer(B) And ByteArray(C + 1) = KeyBuffer(B + 1)) Then Exit For
                                C = C + 2
                            Next B
                            'keyword is found!
                            If B >= KeyLen Then
                                InBArr = A
                                Exit Function
                            End If
                        Else
                            InBArr = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        Else 'vbTextCompare
            FirstKeyByteU = KeyBufferU(0)
            LastKeyByteU = KeyBufferU(KeyLen)
            FirstKeyByte2U = KeyBufferU(1)
            LastKeyByte2U = KeyBufferU(KeyLen + 1)
            'loop through the array
            For A = StartPos To UBound(ByteArray) - KeyLen - 1 Step 2
                TempByte = ByteArray(A)
                TempByte2 = ByteArray(A + 1)
                If (TempByte = FirstKeyByte Or TempByte = FirstKeyByteU) And (TempByte2 = FirstKeyByte2 Or TempByte2 = FirstKeyByte2U) Then
                    TempByte = ByteArray(A + KeyLen)
                    TempByte2 = ByteArray(A + KeyLen + 1)
                    If (TempByte = LastKeyByte Or TempByte = LastKeyByteU) And (TempByte2 = LastKeyByte2 Or TempByte2 = LastKeyByte2U) Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 2
                            For B = 2 To KeyLen - 1 Step 2
                                TempByte = ByteArray(C)
                                TempByte2 = ByteArray(C + 1)
                                If Not ((TempByte = KeyBuffer(B) Or TempByte = KeyBufferU(B)) And (TempByte2 = KeyBuffer(B + 1) Or TempByte2 = KeyBufferU(B + 1))) Then Exit For
                                C = C + 2
                            Next B
                            'keyword is found!
                            If B >= KeyLen Then
                                InBArr = A
                                Exit Function
                            End If
                        Else
                            InBArr = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        End If
    Else
        If StartPos > UBound(ByteArray) - KeyUpper Then StartPos = UBound(ByteArray) - KeyUpper
        FirstKeyByte = KeyBuffer(0)
        LastKeyByte = KeyBuffer(KeyLen)
        If Compare = vbBinaryCompare Then
            'loop through the array
            For A = StartPos To UBound(ByteArray) - KeyUpper
                If ByteArray(A) = FirstKeyByte Then
                    If ByteArray(A + KeyUpper) = LastKeyByte Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 1
                            For B = 2 To KeyLen Step 2
                                If Not (ByteArray(C) = KeyBuffer(B)) Then Exit For
                                C = C + 1
                            Next B
                            'keyword is found!
                            If B > KeyLen Then
                                InBArr = A
                                Exit Function
                            End If
                        Else
                            InBArr = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        Else 'vbTextCompare
            FirstKeyByteU = KeyBufferU(0)
            LastKeyByteU = KeyBufferU(KeyLen)
            'loop through the array
            For A = StartPos To UBound(ByteArray) - KeyUpper
                TempByte = ByteArray(A)
                If TempByte = FirstKeyByte Or TempByte = FirstKeyByteU Then
                    TempByte = ByteArray(A + KeyUpper)
                    If TempByte = LastKeyByte Or TempByte = LastKeyByteU Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 1
                            For B = 2 To KeyLen Step 2
                                TempByte = ByteArray(C)
                                If Not (TempByte = KeyBuffer(B) Or TempByte = KeyBufferU(B)) Then Exit For
                                C = C + 1
                            Next B
                            'keyword is found!
                            If B > KeyLen Then
                                InBArr = A
                                Exit Function
                            End If
                        Else
                            InBArr = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        End If
    End If
    InBArr = -1
End Function

---

It can now handle both ANSI and Unicode byte arrays and it is 100% valid in Unicode mode (note that it can't process ligatures, they're quite bothersome to code support for).

Merri,

Nice one, I think I must be doing something wrong, I'm testing it using this -

VB Code:

Dim fFailed As Boolean
If InBArr(StrConv("a[HL="#FFFF00"]b[/HL]c", vbFromUnicode), "b") <> 1 Then Stop: fFailed = True

I'm getting -1 back when I'm expecting it to return 1??

Any ideas?

Cheers Al

You don't need to use StrConv. It is now Unicode-aware. It will return 2, because a character is two bytes.

VB Code:

' Unicode:
If InBArr("abc", "b") <> 2 Then Stop: fFailed = True
 
' ANSI:
If InBArr(StrConv("abc", vbFromUnicode), "b", , ,False) <> 1 Then Stop: fFailed = True

Merri,

This one is failing am I doing something wrong?

VB Code:

If InBArr(StrConv("abab", vbFromUnicode), "ab", 3, , False) <> 0 Then Stop: fFailed = True

Doesn't seem to recognise the start position, although it's returning 2 so maybe I need to pass it 6 in order to get the correct result, Is that correct?

No that didn't work?

Al

You should have -1 there, not 0 :)

Edit Uh, that of course just by looking at the code, not the comment. Humm... probably an error in the ANSI part of the code. If you try it in Unicode, it should work fine. I haven't validated the ANSI part of the code.

When I try running it in uni mode I get the following error -

_{Compile Error:
Typemismatch: Array or user defined type expected}

here is my call -

VB Code:

If InBArr("abc", "b") <> 2 Then Stop: fFailed = True

Oops, my mistake in the example code there. Should've been:

VB Code:

Dim Temp() As Byte
 
Temp = "abab"
If InBArr(Temp, "b") <> 2 Then Stop: fFailed = True

Here is a complete test code so you don't need to bother as much with the Unicode side of the code. I'm fixing the ANSI side atm.

VB Code:

Public Function IsGoodInBArr(Optional fLigaturesToo As Boolean) As Boolean
' verify correct InStr returns, 20021005
' returns True if all tests are passed
  Dim fFailed As Boolean
  Dim Temp() As Byte
  Dim Test As Long
 
  ' replace ".InStr01" with the name of your function
  Temp = "abc"
  If InBArr(Temp, "b") <> 2 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "ab") <> 0 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "aB") <> -1 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "aB", , vbTextCompare) <> 0 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "ab", 2) <> 4 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "ab", 4) <> 4 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "ab", 6) <> -1 Then Stop: fFailed = True
  Temp = "aaabcab"
  If InBArr(Temp, "abc", 6) <> -1 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "", 6) <> 6 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "", 8) <> 8 Then Stop: fFailed = True
  Erase Temp
  If InBArr(Temp, "", 6) <> -1 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "c") <> -1 Then Stop: fFailed = True
  
  Temp = "abcdabcd"
  If InBArr(Temp, "abcd") <> 0 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "Ab") <> -1 Then Stop: fFailed = True
  Temp = "abab"
  If InBArr(Temp, "Ab", , vbTextCompare) <> 0 Then Stop: fFailed = True
 
  Temp = "a" & String$(50000, "b")
  If InBArr(Temp, "a") <> 0 Then Stop: fFailed = True
  
  ' unicode
  Temp = "a€€c"
  If InBArr(Temp, "€") <> 2 Then Stop: fFailed = True
  
  ' the 4 stooges: š/Š, œ/Œ, ž/Ž, ÿ/Ÿ (154/138, 156/140, 158/142, 255/159)
  Temp = "Hašiš"
  If InBArr(Temp, "Š", , vbTextCompare) <> 4 Then Stop: fFailed = True
  ' ligatures  textcompare (VBspeed entries do NOT have to pass this test)
  If fLigaturesToo Then
    ' ligatures, a digraphemic fun house: ss/ß, ae/æ, oe/œ, th/þ
    Temp = "Straße"
    If InBArr(Temp, "ss", , vbTextCompare) <> 8 Then Stop: fFailed = True
  End If
  
  ' well done
  IsGoodInBArr = Not fFailed
 
End Function

Edit Found the error, it is in both ANSI and Unicode, but there was a second bug in the Unicode mode which prevented it from causing an error. I'll work out the InBArrRev now...

Here is a fresh test project. Try and see if there are any problems :)

Excellent!

These are my test results -

VB Code:

InBArray,      InStr,   InTheStr
TextCompare - [HL="#FFFF00"]642[/HL],       7610,     4196
BinaryCompare-349,        [HL="#FFFF00"]4[/HL],       4540

If you can do binary search then InStr is like lightening
but with textCompare InBArr rules

Obviously this is just one check I'll need to do more thorough testing to get a better idea of it's overall capabilities,

InBRev is very, very slow with both BinaryCompare and TextCompare

You have to note InTheString support only BinaryCompare. Also, InBArrRev should be as fast as InBArr, just searching to opposite direction (from end to beginning)? I get 5 ms vs. 50 ms when I compare InBArrRev to InStrRev with the test file I have.


By using a bigger test file you should get much more accurate test results... at the moment it mainly tests for multiple calls of the function.

Merri, the declaration of lstrlenW in your project was wrong... It should be ByVal, not ByRef... which is why you are always getting 5 (in the other thread). I fixed that and ran my original InTheString function, and also made a new one which is a fair bit faster (but nowhere near InStr.)

Here is the results:

Code:

---

Results (Binary Compare):

InStr:            68 ms: 49533
InTheString2:  8556 ms: 49533
InBArr:        9135 ms: 49532  <-- Out by one
InTheString:    9806 ms: 49533

---

And my InTheString and InTheString2 functions::

Code:

---

Public Function InTheString(ByVal lpszStringToSearch As Long, _
                            ByVal lpszSearchFor As Long, _
                            Optional ByVal plngStartPos As Long = 1 _
                          ) As Long

Dim charBuffer()    As Byte
Dim charSearchFor() As Byte
Dim lngStringLen    As Long
Dim lngString2Len  As Long
Dim lpbSearchFor    As Long
Dim i              As Long
   
    lngStringLen = lstrlenW(lpszStringToSearch) * 2
    lngString2Len = lstrlenW(lpszSearchFor) * 2
       
    ReDim charBuffer(lngStringLen - 1)
    ReDim charSearchFor(lngString2Len - 1)
   
    lpbSearchFor = VarPtr(charSearchFor(0))
   
    RtlMoveMemory charBuffer(0), _
                  ByVal lpszStringToSearch, _
                  lngStringLen - 1
   
    RtlMoveMemory ByVal lpbSearchFor, _
                  ByVal lpszSearchFor, _
                  lngString2Len - 1
   
    If (lngString2Len < lngStringLen) Then
        For i = (plngStartPos - 1) To (lngStringLen - lngString2Len) Step 2
            If (RtlCompareMemory(charBuffer(i), _
                                ByVal lpbSearchFor, _
                                lngString2Len _
                                ) = lngString2Len) Then
                InTheString = (i \ 2) + plngStartPos
                Exit Function
            End If
        Next i
    End If

    InTheString = -1
End Function


Public Function InTheString2(ByVal lpszStringToSearch As Long, _
                            ByVal lpszSearchFor As Long, _
                            Optional ByVal plngStartPos As Long = 1 _
                            ) As Long

Dim charBuffer()    As Byte
Dim charSearchFor() As Byte
Dim lngStringLen    As Long
Dim lngString2Len  As Long
Dim lpbSearchFor    As Long
Dim i              As Long
Dim j              As Long
   
    lngStringLen = lstrlenW(lpszStringToSearch) * 2
    lngString2Len = lstrlenW(lpszSearchFor) * 2
       
    ReDim charBuffer(lngStringLen - 1)
    ReDim charSearchFor(lngString2Len - 1)
   
    lpbSearchFor = VarPtr(charSearchFor(0))
   
    RtlMoveMemory charBuffer(0), _
                  ByVal lpszStringToSearch, _
                  lngStringLen - 1
   
    RtlMoveMemory ByVal lpbSearchFor, _
                  ByVal lpszSearchFor, _
                  lngString2Len - 1
   
    If (lngString2Len < lngStringLen) Then
        For i = (plngStartPos - 1) To (lngStringLen - lngString2Len) Step 2
            Do While (charBuffer(i + j) = charSearchFor(j))
                If j + 1 = UBound(charSearchFor) Then
                    InTheString2 = (i \ 2) + 1
                    Exit Function
                End If
                j = j + 2
            Loop
            j = 0
        Next i
    End If

    InTheString2 = -1
End Function

---

The test keyword I used was "ZwNotifyChangeKey" and the test file (dumpbin on ntdll.dll) is attached:

A few things to think about :)

1) InBArr returns a byte position in the array, it is meant to be off by one (strings start from 1, byte arrays start from 0).
2) You apparently didn't compile your program with all advanced optimizations?
3) My code gets slower with a lot of data; I can optimize it with an API call, but it is bothersome only with bigger keywords. I don't know yet what is the critical length.
4) You should consider using SAFEARRAY instead of RtlMoveMemory... that way you could pass strings ByRef to the function and also gain a speed up. I wanted to use native VB6 code in InBArr to show how much you can really do with it.
5) You didn't post the benchmark code, always appreciated when doing something with it.
6) Your code is actually only six times slower than InStr when compiled. Mine is four times slower (binary mode). Result varies with input data though, I haven't done a proper test with a huge file.
7) Your code doesn't support TextCompare, which is one the main needs; it is often tried to be skipped only because InStr is very slow in TextCompare mode.


Edit I tried your bigger file to do some testing... some results:
InBArr, BinaryCompare: 326 ms
InStr, BinaryCompare: 78 ms
InTheString2: 450 ms

InBArr, TextCompare: 275 ms (!!!)
InStr, TextCompare: 1111 ms

Each one reported the correct position.


Edit #2 I'm now making some further small changes to the code now that I found a way to optimize a bit...

Quote:

---

Originally Posted by Merri

1) InBArr returns a byte position in the array, it is meant to be off by one (strings start from 1, byte arrays start from 0).

---

Then it is returning an offset, not a position ;)

Quote:

---

2) You apparently didn't compile your program with all advanced optimizations?

---

No, it was 4 am, and I ran it from the IDE :eek:

Quote:

---

4) You should consider using SAFEARRAY instead of RtlMoveMemory... that way you could pass strings ByRef to the function and also gain a speed up. I wanted to use native VB6 code in InBArr to show how much you can really do with it.

---

I'm not sure what you mean. All VB arrays are actually SAFEARRAYs, I'm merely using RtlMoveMemory to shift the string into the data buffer part of one. I could also use RtlCompareMemory on the string itself, to save using any byte arrays, but that would result in more API calls which would probably slow it down.

Quote:

---

5) You didn't post the benchmark code, always appreciated when doing something with it.

---

I used yours ;)

Quote:

---

7) Your code doesn't support TextCompare, which is one the main needs; it is often tried to be skipped only because InStr is very slow in TextCompare mode.

---

Added, in a new function :)

I'll post the new function when I have it fixed. It doesn't use any API's and is just slightly slower that yours in binary compare mode. Also it incorporates a benchmarking cheat, it checks each time whether the parameters are the same and if they are then it returns the result it found last time. Doing that I was able to achieve 1 ms for the benchmark :p But it can be commented out.

Quote:

---

Originally Posted by penagate

Then it is returning an offset, not a position ;)

---

Think about it: it is meant to give a position in the array. Not in a string. InBArr is the name and it is much easier to get the correct position value you are using when working with byte arrays. I wasn't making a replacement for InStr, I made a new function to use with byte arrays (because handling byte arrays is faster and there aren't any functions you can use to handle byte arrays).

Quote:

---

Originally Posted by penagate

I'm not sure what you mean. All VB arrays are actually SAFEARRAYs

---

Take a look at VBspeed: http://www.xbeat.net/vbspeed/i_Dope.htm#modules

Quote:

---

Originally Posted by penagate

Also it incorporates a benchmarking cheat, it checks each time whether the parameters are the same and if they are then it returns the result it found last time. Doing that I was able to achieve 1 ms for the benchmark :p But it can be commented out.

---

I had a cheat before, but it broke the function from working properly (I used StrPtr). It seemed to give back an invalid, old value, so it used an old keyword when a keyword changed. 1 ms here or there isn't much.

Here is the new InBArr and InBArrRev... they are both a "bit" faster now (80 ms faster!).

CODE IN NEXT POST BECAUSE IT DIDN'T FIT HERE

Last test with this code:
InBArr, vbBinaryCompare: 221 ms (InStr 79 ms)
InBArr, vbTextCompare: 312 ms

InBArrRev, vbBinaryCompare: 70 ms (InStrRev 190 ms)
InBArrRev, vbTextCompare: 78 ms

Code:

---

Option Explicit
Public Function InBArr(ByRef ByteArray() As Byte, ByRef KeyWord As String, Optional StartPos As Long = 0, Optional Compare As Byte = vbBinaryCompare, Optional IsUnicode As Boolean = True) As Long
    Static KeyBuffer() As Byte, KeyBufferU() As Byte
    Dim A As Long, B As Long, C As Long, KeyLen As Long, KeyUpper As Long
    Dim FirstKeyByte As Byte, LastKeyByte As Byte, TempByte As Byte
    Dim FirstKeyByte2 As Byte, LastKeyByte2 As Byte, TempByte2 As Byte
    Dim FirstKeyByteU As Byte, LastKeyByteU As Byte
    Dim FirstKeyByte2U As Byte, LastKeyByte2U As Byte
    If (Not ByteArray) = True Then InBArr = -1: Exit Function
    If LenB(KeyWord) = 0 Then InBArr = StartPos: Exit Function
    If Compare = vbBinaryCompare Then
        KeyBuffer = KeyWord
    Else
        KeyBufferU = UCase$(KeyWord)
        KeyBuffer = LCase$(KeyWord)
    End If
    KeyLen = UBound(KeyBuffer) - 1
    If StartPos < 0 Then StartPos = 0
    If IsUnicode Then
        If KeyLen > UBound(ByteArray) - 1 Then InBArr = -1: Exit Function
        If (StartPos Mod 2) = 1 Then StartPos = StartPos - (StartPos Mod 2) + 2
        If StartPos > UBound(ByteArray) - KeyLen Then InBArr = -1: Exit Function
        FirstKeyByte = KeyBuffer(0)
        LastKeyByte = KeyBuffer(KeyLen)
        FirstKeyByte2 = KeyBuffer(1)
        LastKeyByte2 = KeyBuffer(KeyLen + 1)
        If Compare = vbBinaryCompare Then
            'loop through the array
            For A = StartPos To UBound(ByteArray) - KeyLen - 1 Step 2
                TempByte = ByteArray(A)
                TempByte2 = ByteArray(A + 1)
                If TempByte = FirstKeyByte And TempByte2 = FirstKeyByte2 Then
                    TempByte = ByteArray(A + KeyLen)
                    TempByte2 = ByteArray(A + KeyLen + 1)
                    If TempByte = LastKeyByte And TempByte2 = LastKeyByte2 Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 2
                            For B = 2 To KeyLen - 1 Step 2
                                If Not (ByteArray(C) = KeyBuffer(B) And ByteArray(C + 1) = CByte(KeyBuffer(B + 1))) Then Exit For
                                C = C + 2
                            Next B
                            'keyword is found!
                            If B >= KeyLen Then
                                InBArr = A
                                Exit Function
                            End If
                        Else
                            InBArr = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        Else 'vbTextCompare
            FirstKeyByteU = KeyBufferU(0)
            LastKeyByteU = KeyBufferU(KeyLen)
            FirstKeyByte2U = KeyBufferU(1)
            LastKeyByte2U = KeyBufferU(KeyLen + 1)
            'loop through the array
            For A = StartPos To UBound(ByteArray) - KeyLen - 1 Step 2
                TempByte = ByteArray(A)
                TempByte2 = ByteArray(A + 1)
                If (TempByte = FirstKeyByte Or TempByte = FirstKeyByteU) And (TempByte2 = FirstKeyByte2 Or TempByte2 = FirstKeyByte2U) Then
                    TempByte = ByteArray(A + KeyLen)
                    TempByte2 = ByteArray(A + KeyLen + 1)
                    If (TempByte = LastKeyByte Or TempByte = LastKeyByteU) And (TempByte2 = LastKeyByte2 Or TempByte2 = LastKeyByte2U) Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 2
                            For B = 2 To KeyLen - 1 Step 2
                                TempByte = ByteArray(C)
                                TempByte2 = ByteArray(C + 1)
                                If Not ((TempByte = KeyBuffer(B) Or TempByte = KeyBufferU(B)) And (TempByte2 = KeyBuffer(B + 1) Or TempByte2 = KeyBufferU(B + 1))) Then Exit For
                                C = C + 2
                            Next B
                            'keyword is found!
                            If B >= KeyLen Then
                                InBArr = A
                                Exit Function
                            End If
                        Else
                            InBArr = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        End If
    Else
        KeyUpper = KeyLen \ 2
        If KeyUpper > UBound(ByteArray) Then InBArr = -1: Exit Function
        If StartPos > UBound(ByteArray) - KeyUpper Then InBArr = -1: Exit Function
        FirstKeyByte = KeyBuffer(0)
        LastKeyByte = KeyBuffer(KeyLen)
        If Compare = vbBinaryCompare Then
            'loop through the array
            Debug.Print StartPos
            For A = StartPos To UBound(ByteArray) - KeyUpper
                If ByteArray(A) = FirstKeyByte Then
                    If ByteArray(A + KeyUpper) = LastKeyByte Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 1
                            For B = 2 To KeyLen Step 2
                                If Not (ByteArray(C) = KeyBuffer(B)) Then Exit For
                                C = C + 1
                            Next B
                            'keyword is found!
                            If B > KeyLen Then
                                InBArr = A
                                Exit Function
                            End If
                        Else
                            InBArr = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        Else 'vbTextCompare
            FirstKeyByteU = KeyBufferU(0)
            LastKeyByteU = KeyBufferU(KeyLen)
            'loop through the array
            For A = StartPos To UBound(ByteArray) - KeyUpper
                TempByte = ByteArray(A)
                If TempByte = FirstKeyByte Or TempByte = FirstKeyByteU Then
                    TempByte = ByteArray(A + KeyUpper)
                    If TempByte = LastKeyByte Or TempByte = LastKeyByteU Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 1
                            For B = 2 To KeyLen Step 2
                                TempByte = ByteArray(C)
                                If Not (TempByte = KeyBuffer(B) Or TempByte = KeyBufferU(B)) Then Exit For
                                C = C + 1
                            Next B
                            'keyword is found!
                            If B > KeyLen Then
                                InBArr = A
                                Exit Function
                            End If
                        Else
                            InBArr = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        End If
    End If
    InBArr = -1
End Function

---

*sniff* Wished I could post longer posts.

Code:

---

Public Function InBArrRev(ByRef ByteArray() As Byte, ByRef KeyWord As String, Optional StartPos As Long = -1, Optional Compare As Byte = vbBinaryCompare, Optional IsUnicode As Boolean = True) As Long
    Static KeyBuffer() As Byte, KeyBufferU() As Byte
    Dim A As Long, B As Long, C As Long, KeyLen As Long, KeyUpper As Long
    Dim FirstKeyByte As Byte, LastKeyByte As Byte, TempByte As Byte
    Dim FirstKeyByte2 As Byte, LastKeyByte2 As Byte, TempByte2 As Byte
    Dim FirstKeyByteU As Byte, LastKeyByteU As Byte
    Dim FirstKeyByte2U As Byte, LastKeyByte2U As Byte
    If (Not ByteArray) = True Then InBArrRev = -1: Exit Function
    If LenB(KeyWord) = 0 Then InBArrRev = StartPos: Exit Function
    If Compare = vbBinaryCompare Then
        KeyBuffer = KeyWord
    Else
        KeyBufferU = UCase$(KeyWord)
        KeyBuffer = LCase$(KeyWord)
    End If
    KeyLen = UBound(KeyBuffer) - 1
    If IsUnicode Then
        If KeyLen > UBound(ByteArray) - 1 Then InBArrRev = -1: Exit Function
        If StartPos < 0 Then StartPos = UBound(ByteArray) - KeyLen - 1
        If (StartPos Mod 2) = 1 Then StartPos = StartPos - (StartPos Mod 2) + 2
        If StartPos >= UBound(ByteArray) - KeyLen Then InBArrRev = -1: Exit Function
        FirstKeyByte = KeyBuffer(0)
        LastKeyByte = KeyBuffer(KeyLen)
        FirstKeyByte2 = KeyBuffer(1)
        LastKeyByte2 = KeyBuffer(KeyLen + 1)
        If Compare = vbBinaryCompare Then
            'loop through the array
            For A = StartPos To 0 Step -2
                TempByte = ByteArray(A)
                TempByte2 = ByteArray(A + 1)
                If TempByte = FirstKeyByte And TempByte2 = FirstKeyByte2 Then
                    TempByte = ByteArray(A + KeyLen)
                    TempByte2 = ByteArray(A + KeyLen + 1)
                    If TempByte = LastKeyByte And TempByte2 = LastKeyByte2 Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 2
                            For B = 2 To KeyLen - 1 Step 2
                                If Not (ByteArray(C) = KeyBuffer(B) And ByteArray(C + 1) = KeyBuffer(B + 1)) Then Exit For
                                C = C + 2
                            Next B
                            'keyword is found!
                            If B >= KeyLen Then
                                InBArrRev = A
                                Exit Function
                            End If
                        Else
                            InBArrRev = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        Else 'vbTextCompare
            FirstKeyByteU = KeyBufferU(0)
            LastKeyByteU = KeyBufferU(KeyLen)
            FirstKeyByte2U = KeyBufferU(1)
            LastKeyByte2U = KeyBufferU(KeyLen + 1)
            'loop through the array
            For A = StartPos To 0 Step -2
                TempByte = ByteArray(A)
                TempByte2 = ByteArray(A + 1)
                If (TempByte = FirstKeyByte Or TempByte = FirstKeyByteU) And (TempByte2 = FirstKeyByte2 Or TempByte2 = FirstKeyByte2U) Then
                    TempByte = ByteArray(A + KeyLen)
                    TempByte2 = ByteArray(A + KeyLen + 1)
                    If (TempByte = LastKeyByte Or TempByte = LastKeyByteU) And (TempByte2 = LastKeyByte2 Or TempByte2 = LastKeyByte2U) Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 2
                            For B = 2 To KeyLen - 1 Step 2
                                TempByte = ByteArray(C)
                                TempByte2 = ByteArray(C + 1)
                                If Not ((TempByte = KeyBuffer(B) Or TempByte = KeyBufferU(B)) And (TempByte2 = KeyBuffer(B + 1) Or TempByte2 = KeyBufferU(B + 1))) Then Exit For
                                C = C + 2
                            Next B
                            'keyword is found!
                            If B >= KeyLen Then
                                InBArrRev = A
                                Exit Function
                            End If
                        Else
                            InBArrRev = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        End If
    Else
        KeyUpper = KeyLen \ 2
        If KeyUpper > UBound(ByteArray) Then InBArrRev = -1: Exit Function
        If StartPos < 0 Then StartPos = UBound(ByteArray) - KeyUpper
        If StartPos > UBound(ByteArray) - KeyUpper Then InBArrRev = -1: Exit Function
        FirstKeyByte = KeyBuffer(0)
        LastKeyByte = KeyBuffer(KeyLen)
        If Compare = vbBinaryCompare Then
            'loop through the array
            Debug.Print StartPos
            For A = StartPos To 0 Step -1
                If ByteArray(A) = FirstKeyByte Then
                    If ByteArray(A + KeyUpper) = LastKeyByte Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 1
                            For B = 2 To KeyLen Step 2
                                If Not (ByteArray(C) = KeyBuffer(B)) Then Exit For
                                C = C + 1
                            Next B
                            'keyword is found!
                            If B > KeyLen Then
                                InBArrRev = A
                                Exit Function
                            End If
                        Else
                            InBArrRev = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        Else 'vbTextCompare
            FirstKeyByteU = KeyBufferU(0)
            LastKeyByteU = KeyBufferU(KeyLen)
            'loop through the array
            For A = StartPos To 0 Step -1
                TempByte = ByteArray(A)
                If TempByte = FirstKeyByte Or TempByte = FirstKeyByteU Then
                    TempByte = ByteArray(A + KeyUpper)
                    If TempByte = LastKeyByte Or TempByte = LastKeyByteU Then
                        If KeyLen > 4 Then
                            'check if keyword is found from the array
                            C = A + 1
                            For B = 2 To KeyLen Step 2
                                TempByte = ByteArray(C)
                                If Not (TempByte = KeyBuffer(B) Or TempByte = KeyBufferU(B)) Then Exit For
                                C = C + 1
                            Next B
                            'keyword is found!
                            If B > KeyLen Then
                                InBArrRev = A
                                Exit Function
                            End If
                        Else
                            InBArrRev = A
                            Exit Function
                        End If
                    End If
                End If
            Next A
        End If
    End If
    InBArrRev = -1
End Function

---

Quote:

---

Originally Posted by Merri

I had a cheat before, but it broke the function from working properly (I used StrPtr). It seemed to give back an invalid, old value, so it used an old keyword when a keyword changed. 1 ms here or there isn't much.

---

I had that problem but fixed it now. The essence of mine is the same as yours.

I used static variables to hold the last paramaters (pointer to string to search, pointer to keyword string, starting pos, compare method, Unicode/ANSI) and at the start of the function it checks to see if any of those has changed. If they have it re-loops through the string, otherwise it just spits back the last result (also held in a static).

Er... you don't check if a contents in the string have changed? Because StrPtr might not change even though string contents change. You have to loop through, cheating that much gives both invalid results in real use and gives false information about the speed of the function. Also, I did those other checks, but that doesn't change the fact that StrPtr sometimes gives invalid results. So I got rid of the check and got the 1 ms or so extra. Doesn't hurt too much.

I thought about making Keyword an optional parameter, so the coder could optimize the speed that way. So keyword could stay the same.

No, if you change the string between 2 subsequent calls the pointer will have changed. Unless both of your strings go out of scope and VB allocates a new string to the original. I didn't think of that. I suppose you could test a combination of VarPtr and StrPtr.

But think about it: it is possible to change contents of a string with CopyMemory for example. The pointer doesn't change in that case. Or someone can use an external ASM library which does something and the pointer doesn't change.

Merri,

I have what is probably a dumb question but I'm going to ask it anyway -

If the user has opted for vbTextCompare why don't you just lCase the string then do binary compare as normal? This would cut out a big chunk of your code guess the trade off would would mean passing the buffer byVal as opposed to byRef?


Hmmm probably because doing a binary array check is so slow

Al

I can't do LCase$ to an array :) Besides doing LCase$ to data that might be even 10 MB or more... you get the picture. It is super slow. That is probably what InStr does in TextCompare and that's the reason it is so slow.

Also, arrays must be passed ByRef. They can't be passed ByVal. ByRef is also faster, because there is no need to make a copy of the variable.


And for the last words, doing binary comparison is super fast. Also... my current version of InBArr is almost as fast in TextCompare as it is in BinaryCompare. I've used a few tricks in the code to strip down unrequired calculations. Doing fast code means that the code must be long as well.

InBArrBM at Planet Source Code

This is a boosted version using the Boyer-Moore string searching algorithm. It doesn't work as fast in all cases, but it beats InStr very well under many circumtances. It is perfect for searching a lot of text with a longer keyword (suprisingly, the longer the keyword, the faster it searches [except if there is a lot of content like the keyword]). It doesn't need to make as much work as InStr which works with brute force logic.

It isn't very hard to change it to count strings: just instead of exit function you count up and continue from where you were.


Oh, and due to the nature of Boyer-Moore, there is a keyword optimization. It checks if the keyword has changed or not and if the settings have changed. I used a pretty weird approach, it is within a Do Loop which isn't actually a loop. I noticed that if I used Goto, the function slowed down for some reason.

Merri,

I've tried checking the speed but I'm getting dodgy results

If you get time check this out and see what results you get

forgive me: The test cases have been put together in a rush so could definitely be better as well as presented better :o

Cheers Al

Just use the benchmark application I provided with InBArrBM, it does the same things without the bugs. It is much easier to add your own benchmarks :)

You've atleast done an error with the Unicode part: VB strings already are Unicode, you don't need to remake them Unicode.

Merri,

Good stuff, I was about to post my results which were very unfavourable when run from the vbProject window, but when run from the compiled optimized exe it's very quick, good work! I've given you 5 stars on PSC!! I had to substitute your timer module for a timer class I've got as I keep getting a "calculation too complex" error with yours.

I notice too that you've changed it to return the same position as InStr() which I think is a good thing

Cheers Al

There is only a code that changes InStr and InBArr values to be identical in all cases, so yuu can easily compare the results with eachother. I give you a few examples why InBArr gives a different position value:

VB Code:

Dim Temp As String
' set a string
Temp = "abc"
' return the letter b if it exists in the string (we get an error if it doesn't)
MsgBox Mid$(Temp, InStr(Temp, "b", 1))

This code returns a string with text B in it.

VB Code:

Dim Temp() As Byte, PosValue As Long
Dim Temp2() As Byte
' the array will be filled with UTF-16 character data (2 bytes/character)
Temp = "abc"
' get position in array
PosValue = InBArrBM(Temp, "b")
' reserve enough memory for another temporary array
ReDim Temp2(1)
' fill the character into this array
Temp2(0) = Temp(PosValue)
Temp2(1) = Temp(PosValue + 1)
' convert the array to a string and display in a messagebox
MsgBox CStr(Temp2)

This isn't the best possible example, but it clearly shows why it doesn't give the same value than InStr. I didn't code a support for Option Base 1 because that would be a killer to the performance. Besides handling Option Base 0 (default) is much easier for a programmer as well once he gets used to it.

Why couldnt you use isntr to count the number of times a letter or word repeats? Seems the fastest to me..

Hi,

Yes you could, here is an example,
http://www.xbeat.net/vbspeed/c_InStr...m#InStrCount01

but I believe Merri's InBArrBM is faster

Cheers Al

InStr is very slow especially when you use TextCompare. InStr doesn't even use any special technique to perform the search, it does it the hard brute force way (ie. checks every single byte). So that is why I coded something that is faster than InStr in many normal search situatations; and knowing InStr is most likely coded in ASM, it isn't a bad result. Though the main aim with my function was to provide a search function for byte arrays; beating InStr was a secondary goal.

Btw, there are some people who have made ThunderVB, which allows adding ASM code into a VB6 app. Afaik they've made InStr replacement using Boyer-Moore, which should beat the native InStr in about every possible case.

I think myself and Penegate tied this up quite nicely with:http://www.vbforums.com/showthread.p...13#post2140013

Let me know if you can improve upon what's going on here.

The codes seem to lack Unicode support which gives invalid results when some special character languages are used. They also lack TextCompare support. Full codes would be nice so I didn't need to guess all the variables and API declarations used out-of-the-function.

Quote:

---

Originally Posted by Merri

The codes seem to lack Unicode support which gives invalid results when some special character languages are used. They also lack TextCompare support. Full codes would be nice so I didn't need to guess all the variables and API declarations used out-of-the-function.

---

Wrong thread?

Well, if you're planning to make a proper InStrCount, you need to have Unicode and TextCompare support. Both your and penagate's codes there seem to check for every other byte. penagate's code also crashes if the keyword is longer than one character.

What is the real goal with the functions? They seem more like an ANSI character counters than functions looking for the number of strings within a string.

Take the i=i+2, and change it to i=i+1 then? :)

Hmm, so which code snippet I should actually be looking at? The one you directly linked to or the ones that were optimized? I started from the end of the thread.

VB Code:

Public Function Sisic4(pStr As Long, pFind As Long, lenStr As Long, lenFind As Long) As Long
 
    Dim i As Long
    Dim j As Long
    Dim Flag As Long
        CopyMemory BufStr(0), ByVal pStr, lenStr
    CopyMemory BufFind(0), ByVal pFind, lenFind
    
    i = lenStr - 1
    
    If lenFind = 2 Then
        Do Until i < lenFind
            If BufStr(i - 1) = BufFind(0) Then
                Sisic4 = Sisic4 + 1
            End If
            i = i - 2
        Loop
    Else
        Do Until i < lenFind
            Flag = 0
            j = lenFind - 1
            Do Until j < 0
                If Not (BufStr(i - (lenFind - j)) = BufFind(j - 1)) Then
                    Flag = -1
                    Exit Do
                End If
                j = j - 2
            Loop
            If Flag = 0 Then
                Sisic4 = Sisic4 + 1
            End If
            i = i - 2
        Loop
    End If
End Function

Here's the stable version of my effort: penegate has some concerns over my final effort.

You will need to define arrays outside of the function. If you change the '-2' to '-1' you should have a unicode compliant function.

BTW: SISIC stands for "String In String Instance Count"

Your function didn't find "Now" as a keyword. It also fails with longer strings, because the byte array is always 512 bytes long... guess I'll increase the length manually. But that really isn't a great way to do it, imo.

It didn't find 'Now' ? Oops must be a bug.

As for whether or not it's a good or bad way? Depends on how you write your code, I guess.

I nearly always allocate 2k of heap for a process at application start up for stuff like this, so it makes no odds about the arrays (I copy the string to the heap and modify the pvData in the SAFEARRAY descriptor to the right place on the heap (as well as modifying other parts of the descriptor)

In terms of efficiency, both peneage, and myself believe that this is probably the fastest way of doing the job.

As you know speed nearly always compromises readibility

I'm looking for a way doing it in Unicode and without a fixed size array. I'm doing pretty well atm I guess. Still some work to do though.

It doesn't include the very first character into the search, that is why it fails.