Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?


DevX Home    Today's Headlines   Articles Archive   Tip Bank   Forums   

Results 1 to 9 of 9

Thread: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

  1. #1
    Joe \Nuke Me Xemu\ Foster Guest

    Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    I've recently been mucking about with string code that involves
    repeatedly calling InStr with essentially the same arguments. This
    may be OK when Compare is vbBinaryCompare, but it sucks when it's
    anything else! So, is there a decent way to transform calls like
    this, InStr(w, x, y, z), where z <> vbBinaryCompare, into calls more
    like InStr(w, x1, y1, vbBinaryCompare) ? Here's my test code, which
    fails even on "A":

    Sub TestStrMangle(Optional ByVal z As VbCompareMethod = vbTextCompare)
    Dim x As String: x = Space$(65536)
    Dim i As Long: For i = 0 To 65535
    Mid$(x, i + 1) = ChrW$(i)
    Next

    Dim x1 As String: x1 = UCase$(x) ' TODO: use a transformation that works

    For i = 0 To 65535
    If (i And 255) = 0 Then Debug.Print i;
    Dim y As String: y = ChrW$(i)
    Dim y1 As String: y1 = UCase$(y) ' TODO: use a transformation that works
    Dim w As Long: w = 1
    Do
    Dim p0 As Long: p0 = InStr(w, x, y, z)
    Dim p1 As Long: p1 = InStr(w, x1, y1, vbBinaryCompare)
    If p0 <> p1 Then
    Debug.Print vbNewLine; "i ="; i; "w ="; w; "p0 ="; p0; "p1 ="; p1
    Stop
    End If
    w = p0 + 1
    Loop While p0
    Next
    End Sub

    --
    Joe Foster <mailto:jlfoster%40znet.com> Space Cooties! <http://www.xenu.net/>
    WARNING: I cannot be held responsible for the above They're coming to
    because my cats have apparently learned to type. take me away, ha ha!



  2. #2
    Michael \(michka\) Kaplan Guest

    Re: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    The EASIEST way is to define your own public InStr function in a module:

    Public Function InStr( _
    ByVal Start As Variant, _
    ByVal String1 As Variant, _
    Optional ByVal string2 As Variant, _
    Optional Compare As VbCompareMethod = vbBinaryCompare _
    ) As Variant

    If IsMissing(string2) Then
    InStr = VBA.InStr(1, Start, String1, Compare)
    Else
    InStr = VBA.InStr(Start, String1, string2, Compare)
    End If
    End Function


    This function will now always be called instead of the original.



    --
    MichKa

    Michael Kaplan
    (principal developer of the MSLU)
    Trigeminal Software, Inc. -- http://www.trigeminal.com/
    the book -- http://www.i18nWithVB.com/

    "Joe "Nuke Me Xemu" Foster" <joe@bftsi0.UUCP> wrote in message
    news:3c1c1dee@147.208.176.211...
    > I've recently been mucking about with string code that involves
    > repeatedly calling InStr with essentially the same arguments. This
    > may be OK when Compare is vbBinaryCompare, but it sucks when it's
    > anything else! So, is there a decent way to transform calls like
    > this, InStr(w, x, y, z), where z <> vbBinaryCompare, into calls more
    > like InStr(w, x1, y1, vbBinaryCompare) ? Here's my test code, which
    > fails even on "A":
    >
    > Sub TestStrMangle(Optional ByVal z As VbCompareMethod = vbTextCompare)
    > Dim x As String: x = Space$(65536)
    > Dim i As Long: For i = 0 To 65535
    > Mid$(x, i + 1) = ChrW$(i)
    > Next
    >
    > Dim x1 As String: x1 = UCase$(x) ' TODO: use a transformation that works
    >
    > For i = 0 To 65535
    > If (i And 255) = 0 Then Debug.Print i;
    > Dim y As String: y = ChrW$(i)
    > Dim y1 As String: y1 = UCase$(y) ' TODO: use a transformation that

    works
    > Dim w As Long: w = 1
    > Do
    > Dim p0 As Long: p0 = InStr(w, x, y, z)
    > Dim p1 As Long: p1 = InStr(w, x1, y1, vbBinaryCompare)
    > If p0 <> p1 Then
    > Debug.Print vbNewLine; "i ="; i; "w ="; w; "p0 ="; p0; "p1 ="; p1
    > Stop
    > End If
    > w = p0 + 1
    > Loop While p0
    > Next
    > End Sub
    >
    > --
    > Joe Foster <mailto:jlfoster%40znet.com> Space Cooties!

    <http://www.xenu.net/>
    > WARNING: I cannot be held responsible for the above They're

    coming to
    > because my cats have apparently learned to type. take me away,

    ha ha!
    >
    >




  3. #3
    Michael \(michka\) Kaplan Guest

    Re: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    The EASIEST way is to define your own public InStr function in a module:

    Public Function InStr( _
    ByVal Start As Variant, _
    ByVal String1 As Variant, _
    Optional ByVal string2 As Variant, _
    Optional Compare As VbCompareMethod = vbBinaryCompare _
    ) As Variant

    If IsMissing(string2) Then
    InStr = VBA.InStr(1, Start, String1, Compare)
    Else
    InStr = VBA.InStr(Start, String1, string2, Compare)
    End If
    End Function


    This function will now always be called instead of the original.



    --
    MichKa

    Michael Kaplan
    (principal developer of the MSLU)
    Trigeminal Software, Inc. -- http://www.trigeminal.com/
    the book -- http://www.i18nWithVB.com/

    "Joe "Nuke Me Xemu" Foster" <joe@bftsi0.UUCP> wrote in message
    news:3c1c1dee@147.208.176.211...
    > I've recently been mucking about with string code that involves
    > repeatedly calling InStr with essentially the same arguments. This
    > may be OK when Compare is vbBinaryCompare, but it sucks when it's
    > anything else! So, is there a decent way to transform calls like
    > this, InStr(w, x, y, z), where z <> vbBinaryCompare, into calls more
    > like InStr(w, x1, y1, vbBinaryCompare) ? Here's my test code, which
    > fails even on "A":
    >
    > Sub TestStrMangle(Optional ByVal z As VbCompareMethod = vbTextCompare)
    > Dim x As String: x = Space$(65536)
    > Dim i As Long: For i = 0 To 65535
    > Mid$(x, i + 1) = ChrW$(i)
    > Next
    >
    > Dim x1 As String: x1 = UCase$(x) ' TODO: use a transformation that works
    >
    > For i = 0 To 65535
    > If (i And 255) = 0 Then Debug.Print i;
    > Dim y As String: y = ChrW$(i)
    > Dim y1 As String: y1 = UCase$(y) ' TODO: use a transformation that

    works
    > Dim w As Long: w = 1
    > Do
    > Dim p0 As Long: p0 = InStr(w, x, y, z)
    > Dim p1 As Long: p1 = InStr(w, x1, y1, vbBinaryCompare)
    > If p0 <> p1 Then
    > Debug.Print vbNewLine; "i ="; i; "w ="; w; "p0 ="; p0; "p1 ="; p1
    > Stop
    > End If
    > w = p0 + 1
    > Loop While p0
    > Next
    > End Sub
    >
    > --
    > Joe Foster <mailto:jlfoster%40znet.com> Space Cooties!

    <http://www.xenu.net/>
    > WARNING: I cannot be held responsible for the above They're

    coming to
    > because my cats have apparently learned to type. take me away,

    ha ha!
    >
    >




  4. #4
    Joe \Nuke Me Xemu\ Foster Guest

    Re: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    "Michael (michka) Kaplan" <former_mvp@nospam.trigeminal.spamless.com> wrote in message <news:3c1d316d@147.208.176.211>...

    > The EASIEST way is to define your own public InStr function in a module:


    Unfortunately, that isn't at all what I was asking. Let's say I'm calling
    InStr repeatedly with the same strings, to find all occurrences of y in x:

    dim result() as long, rcount as long, pos as long
    redim result(0 to 15)
    do
    pos = instr(pos + 1, x, y, vbtextcompare)
    if pos = 0 then exit do
    if rcount > ubound(result) then redim preserve result(0 to rcount * 2)
    result(rcount) = pos
    rcount = rcount + 1
    loop

    Now, I've noticed that calling instr with any compare method other than
    vbbinarycompare is damned slow, as if instr is converting the strings
    somehow before starting its search when the compare method is anything
    other than vbbinarycompare. Is there a way I can do this conversion
    myself, in order to save instr from having to spin its wheels like that?
    My first stab at doing this looked something like this:

    ' InStr is slow when used with a compare method other than vbBinaryCompare!
    ' However, is InStr(S, S1, S2, 1) always equivalent to InStr(S, LCase$(S1), LCase$(S2), 0)?
    If Compare = vbTextCompare Then
    StringCheck = LCase$(StringCheck)
    StringMatch = LCase$(StringMatch)
    Compare = vbBinaryCompare
    End If

    Obviously, this won't really work. Remember, the code later on repeatedly
    calls instr with these same strings and compare method. Is there something
    that *will* work, as verified by the code in my original post? Is there a
    way to do this when Compare is a locale ID or perhaps even a Field object's
    CollatingOrder property?

    --
    Joe Foster <mailto:jlfoster%40znet.com> Sacrament R2-45 <http://www.xenu.net/>
    WARNING: I cannot be held responsible for the above They're coming to
    because my cats have apparently learned to type. take me away, ha ha!



  5. #5
    Joe \Nuke Me Xemu\ Foster Guest

    Re: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    "Michael (michka) Kaplan" <former_mvp@nospam.trigeminal.spamless.com> wrote in message <news:3c1d316d@147.208.176.211>...

    > The EASIEST way is to define your own public InStr function in a module:


    Unfortunately, that isn't at all what I was asking. Let's say I'm calling
    InStr repeatedly with the same strings, to find all occurrences of y in x:

    dim result() as long, rcount as long, pos as long
    redim result(0 to 15)
    do
    pos = instr(pos + 1, x, y, vbtextcompare)
    if pos = 0 then exit do
    if rcount > ubound(result) then redim preserve result(0 to rcount * 2)
    result(rcount) = pos
    rcount = rcount + 1
    loop

    Now, I've noticed that calling instr with any compare method other than
    vbbinarycompare is damned slow, as if instr is converting the strings
    somehow before starting its search when the compare method is anything
    other than vbbinarycompare. Is there a way I can do this conversion
    myself, in order to save instr from having to spin its wheels like that?
    My first stab at doing this looked something like this:

    ' InStr is slow when used with a compare method other than vbBinaryCompare!
    ' However, is InStr(S, S1, S2, 1) always equivalent to InStr(S, LCase$(S1), LCase$(S2), 0)?
    If Compare = vbTextCompare Then
    StringCheck = LCase$(StringCheck)
    StringMatch = LCase$(StringMatch)
    Compare = vbBinaryCompare
    End If

    Obviously, this won't really work. Remember, the code later on repeatedly
    calls instr with these same strings and compare method. Is there something
    that *will* work, as verified by the code in my original post? Is there a
    way to do this when Compare is a locale ID or perhaps even a Field object's
    CollatingOrder property?

    --
    Joe Foster <mailto:jlfoster%40znet.com> Sacrament R2-45 <http://www.xenu.net/>
    WARNING: I cannot be held responsible for the above They're coming to
    because my cats have apparently learned to type. take me away, ha ha!



  6. #6
    Michael \(michka\) Kaplan Guest

    Re: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    No, there is no way to do this, using InStr.


    --
    MichKa

    Michael Kaplan
    (principal developer of the MSLU)
    Trigeminal Software, Inc. -- http://www.trigeminal.com/
    the book -- http://www.i18nWithVB.com/


    "Joe "Nuke Me Xemu" Foster" <joe@bftsi0.UUCP> wrote in message
    news:3c1d513e@147.208.176.211...
    > "Michael (michka) Kaplan" <former_mvp@nospam.trigeminal.spamless.com>

    wrote in message <news:3c1d316d@147.208.176.211>...
    >
    > > The EASIEST way is to define your own public InStr function in a module:

    >
    > Unfortunately, that isn't at all what I was asking. Let's say I'm calling
    > InStr repeatedly with the same strings, to find all occurrences of y in x:
    >
    > dim result() as long, rcount as long, pos as long
    > redim result(0 to 15)
    > do
    > pos = instr(pos + 1, x, y, vbtextcompare)
    > if pos = 0 then exit do
    > if rcount > ubound(result) then redim preserve result(0 to rcount * 2)
    > result(rcount) = pos
    > rcount = rcount + 1
    > loop
    >
    > Now, I've noticed that calling instr with any compare method other than
    > vbbinarycompare is damned slow, as if instr is converting the strings
    > somehow before starting its search when the compare method is anything
    > other than vbbinarycompare. Is there a way I can do this conversion
    > myself, in order to save instr from having to spin its wheels like that?
    > My first stab at doing this looked something like this:
    >
    > ' InStr is slow when used with a compare method other than

    vbBinaryCompare!
    > ' However, is InStr(S, S1, S2, 1) always equivalent to InStr(S,

    LCase$(S1), LCase$(S2), 0)?
    > If Compare = vbTextCompare Then
    > StringCheck = LCase$(StringCheck)
    > StringMatch = LCase$(StringMatch)
    > Compare = vbBinaryCompare
    > End If
    >
    > Obviously, this won't really work. Remember, the code later on repeatedly
    > calls instr with these same strings and compare method. Is there

    something
    > that *will* work, as verified by the code in my original post? Is there a
    > way to do this when Compare is a locale ID or perhaps even a Field

    object's
    > CollatingOrder property?
    >
    > --
    > Joe Foster <mailto:jlfoster%40znet.com> Sacrament R2-45

    <http://www.xenu.net/>
    > WARNING: I cannot be held responsible for the above They're

    coming to
    > because my cats have apparently learned to type. take me away,

    ha ha!
    >
    >




  7. #7
    Michael \(michka\) Kaplan Guest

    Re: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    No, there is no way to do this, using InStr.


    --
    MichKa

    Michael Kaplan
    (principal developer of the MSLU)
    Trigeminal Software, Inc. -- http://www.trigeminal.com/
    the book -- http://www.i18nWithVB.com/


    "Joe "Nuke Me Xemu" Foster" <joe@bftsi0.UUCP> wrote in message
    news:3c1d513e@147.208.176.211...
    > "Michael (michka) Kaplan" <former_mvp@nospam.trigeminal.spamless.com>

    wrote in message <news:3c1d316d@147.208.176.211>...
    >
    > > The EASIEST way is to define your own public InStr function in a module:

    >
    > Unfortunately, that isn't at all what I was asking. Let's say I'm calling
    > InStr repeatedly with the same strings, to find all occurrences of y in x:
    >
    > dim result() as long, rcount as long, pos as long
    > redim result(0 to 15)
    > do
    > pos = instr(pos + 1, x, y, vbtextcompare)
    > if pos = 0 then exit do
    > if rcount > ubound(result) then redim preserve result(0 to rcount * 2)
    > result(rcount) = pos
    > rcount = rcount + 1
    > loop
    >
    > Now, I've noticed that calling instr with any compare method other than
    > vbbinarycompare is damned slow, as if instr is converting the strings
    > somehow before starting its search when the compare method is anything
    > other than vbbinarycompare. Is there a way I can do this conversion
    > myself, in order to save instr from having to spin its wheels like that?
    > My first stab at doing this looked something like this:
    >
    > ' InStr is slow when used with a compare method other than

    vbBinaryCompare!
    > ' However, is InStr(S, S1, S2, 1) always equivalent to InStr(S,

    LCase$(S1), LCase$(S2), 0)?
    > If Compare = vbTextCompare Then
    > StringCheck = LCase$(StringCheck)
    > StringMatch = LCase$(StringMatch)
    > Compare = vbBinaryCompare
    > End If
    >
    > Obviously, this won't really work. Remember, the code later on repeatedly
    > calls instr with these same strings and compare method. Is there

    something
    > that *will* work, as verified by the code in my original post? Is there a
    > way to do this when Compare is a locale ID or perhaps even a Field

    object's
    > CollatingOrder property?
    >
    > --
    > Joe Foster <mailto:jlfoster%40znet.com> Sacrament R2-45

    <http://www.xenu.net/>
    > WARNING: I cannot be held responsible for the above They're

    coming to
    > because my cats have apparently learned to type. take me away,

    ha ha!
    >
    >




  8. #8
    Joe \Nuke Me Xemu\ Foster Guest

    Re: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    "Michael (michka) Kaplan" <former_mvp@nospam.trigeminal.spamless.com> wrote in message <news:3c1d5a10$1@147.208.176.211>...

    > No, there is no way to do this, using InStr.


    I thought I almost had something, based on a sort of bastardized Boyer-
    Moore string search, but then I ran into "ae" and "" a/k/a chr$(230),
    and who knows what other gotchas are out there in Unicode-land... =(
    Of course, all such concerns will go away in TEOVBAWKI.NET, right?

    Here's what I have so far. When it does work, it can blow the doors
    off of an equivalent function which uses only InStr in a loop. Oh well,
    maybe someone can salvage something useful from the wreckage:

    Function InStrAllEx(ByVal StringCheck As String, ByVal StringMatch As String, _
    Optional ByVal Start As Long = 1, Optional ByVal Limit As Long = -1, _
    Optional ByVal Overlaps As Boolean = True, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Variant

    Dim LSC As Long: LSC = Len(StringCheck)
    Dim LSM As Long: LSM = Len(StringMatch)
    Dim Result() As Long, RCount As Long

    ' greasy Split/Replace compatibility stuff
    If Limit < -1 Or Start < 1 Then
    Err.Raise 5
    ElseIf LSM = 0 Then
    ReDim Result(0 To 0)
    Result(0) = Start
    InStrAllEx = Result
    Exit Function
    ElseIf LSC = 0 Or Limit = 0 Then
    InStrAllEx = Array()
    Exit Function
    End If

    Static Chars As String
    Dim i As Long, j As Long, K As Long, C As String

    ' initialize our character table
    If Len(Chars) = 0 Then
    Chars = Space$(256)
    For K = 1 To 256
    Mid$(Chars, K) = Chr$(K - 1)
    Next
    End If

    ' construct something like a Boyer-Moore skip table
    Dim Positions(0 To 255) As Long
    For i = 1 To LSM
    C = Mid$(StringMatch, i, 1)
    K = InStr(1, Chars, C, Compare)
    Do
    Positions(K - 1) = i
    K = InStr(K + 1, Chars, C, Compare)
    Loop While K
    Next

    If Limit < 1 Or Limit > 1000 Then ReDim Result(0 To 15) _
    Else ReDim Result(0 To Limit - 1)

    Dim Stride As Long: If Overlaps Then Stride = 1 Else Stride = LSM
    Start = Start - 1 + LSM
    Do
    If Start > LSC Then Exit Do
    'Debug.Print Start;
    i = Positions(Asc(Mid$(StringCheck, Start, 1)))
    If i = 0 Then
    ' current character is not within StringMatch
    Start = Start + LSM
    Else ' we have a match on at least one character
    i = Start - i + 1 ' start of leftmost possible match
    j = i - 1 + LSM ' end of leftmost possible match

    ' is the last character of StringMatch at end of the possible match?
    If j = Start Then
    ' we're already at the end of the possible match
    K = LSM
    ElseIf j > LSC Then
    ' end of leftmost possible match is past end of StringCheck!
    Exit Do
    Else
    K = Positions(Asc(Mid$(StringCheck, j, 1)))
    End If

    If K = 0 Then
    ' end of possible match not within StringMatch at all
    Start = j + LSM
    ElseIf K <> LSM Then
    ' EoPM is some other character within StringMatch
    Start = j + 1
    ElseIf InStr(1, Mid$(StringCheck, i, LSM), StringMatch, Compare) <> 1 Then
    ' the rest of the characters don't match
    Start = j + 1
    Else
    ' we have a match!
    If RCount > UBound(Result) Then ReDim Preserve Result(0 To RCount * 2)
    Result(RCount) = i
    RCount = RCount + 1
    If Limit <> 1 Then Limit = Limit - 1 Else Exit Do
    Start = j + Stride
    End If
    End If
    Loop

    If RCount = 0 Then
    InStrAllEx = Array()
    Else
    ReDim Preserve Result(0 To RCount - 1)
    InStrAllEx = Result
    End If
    End Function

    Here's the InStr-in-a-loop reference version:

    Function InStrAll(ByVal StringCheck As String, ByVal StringMatch As String, _
    Optional ByVal Start As Long = 1, Optional ByVal Limit As Long = -1, _
    Optional ByVal Overlaps As Boolean = True, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Variant

    Dim LSC As Long: LSC = Len(StringCheck)
    Dim LSM As Long: LSM = Len(StringMatch)
    Dim Result() As Long, RCount As Long

    ' greasy Split/Replace compatibility stuff
    If Limit < -1 Or Start < 1 Then
    Err.Raise 5
    ElseIf LSM = 0 Then
    ReDim Result(0 To 0)
    Result(0) = Start
    InStrAll = Result
    Exit Function
    ElseIf LSC = 0 Or Limit = 0 Then
    InStrAll = Array()
    Exit Function
    End If

    If Limit < 1 Or Limit > 1000 Then ReDim Result(0 To 15) _
    Else ReDim Result(0 To Limit - 1)

    Dim Stride As Long: If Overlaps Then Stride = 1 Else Stride = LSM
    Do
    Start = InStr(Start, StringCheck, StringMatch, Compare)
    If Start = 0 Then Exit Do

    If RCount > UBound(Result) Then ReDim Preserve Result(0 To RCount * 2)
    Result(RCount) = Start
    RCount = RCount + 1

    If Limit <> 1 Then Limit = Limit - 1 Else Exit Do
    Start = Start + Stride
    Loop

    If RCount = 0 Then
    InStrAll = Array()
    Else
    ReDim Preserve Result(0 To RCount - 1)
    InStrAll = Result
    End If
    End Function

    Here's the test harness:

    Declare Function timeGetTime Lib "WinMM" () As Long
    Declare Function timeBeginPeriod Lib "WinMM" (ByVal p As Long) As Long
    Declare Function timeEndPeriod Lib "WinMM" (ByVal p As Long) As Long

    Function StringXP(ByVal Number As Long, ByVal What As String) As String
    StringXP = Space$(Number * Len(What))
    Mid$(StringXP, 1) = What
    Mid$(StringXP, Len(What) + 1) = StringXP
    End Function

    Sub InStrTest()
    Dim sc As String: sc = StringXP(1000, "Supercalifragilisticexpialidocious")
    Dim sm As String: sm = "SuperSoaker"
    Mid$(sc, Len(sc) - 100) = "SupersoaKeR"

    Const Compare = vbTextCompare

    timeBeginPeriod 1

    Dim t0 As Long: t0 = timeGetTime
    Dim r0 As Variant: r0 = InStrAllEx(sc, sm, , , , Compare)
    t0 = timeGetTime - t0

    Debug.Print UBound(r0) - LBound(r0) + 1; "matches in"; t0;

    Dim t1 As Long: t1 = timeGetTime
    Dim r1 As Variant: r1 = InStrAll(sc, sm, , , , Compare)
    t1 = timeGetTime - t1

    timeEndPeriod 1

    Debug.Print t1

    Debug.Assert LBound(r0) = LBound(r1) And UBound(r0) = UBound(r1)
    Dim i As Long: For i = LBound(r0) To UBound(r0)
    Debug.Assert r0(i) = r1(i)
    Next
    End Sub

    --
    Joe Foster <mailto:jlfoster%40znet.com> On the cans? <http://www.xenu.net/>
    WARNING: I cannot be held responsible for the above They're coming to
    because my cats have apparently learned to type. take me away, ha ha!



  9. #9
    Joe \Nuke Me Xemu\ Foster Guest

    Re: Turn InStr(w, x, y, z) into InStr(w, x1, y1, vbBinaryCompare) ?

    "Michael (michka) Kaplan" <former_mvp@nospam.trigeminal.spamless.com> wrote in message <news:3c1d5a10$1@147.208.176.211>...

    > No, there is no way to do this, using InStr.


    I thought I almost had something, based on a sort of bastardized Boyer-
    Moore string search, but then I ran into "ae" and "" a/k/a chr$(230),
    and who knows what other gotchas are out there in Unicode-land... =(
    Of course, all such concerns will go away in TEOVBAWKI.NET, right?

    Here's what I have so far. When it does work, it can blow the doors
    off of an equivalent function which uses only InStr in a loop. Oh well,
    maybe someone can salvage something useful from the wreckage:

    Function InStrAllEx(ByVal StringCheck As String, ByVal StringMatch As String, _
    Optional ByVal Start As Long = 1, Optional ByVal Limit As Long = -1, _
    Optional ByVal Overlaps As Boolean = True, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Variant

    Dim LSC As Long: LSC = Len(StringCheck)
    Dim LSM As Long: LSM = Len(StringMatch)
    Dim Result() As Long, RCount As Long

    ' greasy Split/Replace compatibility stuff
    If Limit < -1 Or Start < 1 Then
    Err.Raise 5
    ElseIf LSM = 0 Then
    ReDim Result(0 To 0)
    Result(0) = Start
    InStrAllEx = Result
    Exit Function
    ElseIf LSC = 0 Or Limit = 0 Then
    InStrAllEx = Array()
    Exit Function
    End If

    Static Chars As String
    Dim i As Long, j As Long, K As Long, C As String

    ' initialize our character table
    If Len(Chars) = 0 Then
    Chars = Space$(256)
    For K = 1 To 256
    Mid$(Chars, K) = Chr$(K - 1)
    Next
    End If

    ' construct something like a Boyer-Moore skip table
    Dim Positions(0 To 255) As Long
    For i = 1 To LSM
    C = Mid$(StringMatch, i, 1)
    K = InStr(1, Chars, C, Compare)
    Do
    Positions(K - 1) = i
    K = InStr(K + 1, Chars, C, Compare)
    Loop While K
    Next

    If Limit < 1 Or Limit > 1000 Then ReDim Result(0 To 15) _
    Else ReDim Result(0 To Limit - 1)

    Dim Stride As Long: If Overlaps Then Stride = 1 Else Stride = LSM
    Start = Start - 1 + LSM
    Do
    If Start > LSC Then Exit Do
    'Debug.Print Start;
    i = Positions(Asc(Mid$(StringCheck, Start, 1)))
    If i = 0 Then
    ' current character is not within StringMatch
    Start = Start + LSM
    Else ' we have a match on at least one character
    i = Start - i + 1 ' start of leftmost possible match
    j = i - 1 + LSM ' end of leftmost possible match

    ' is the last character of StringMatch at end of the possible match?
    If j = Start Then
    ' we're already at the end of the possible match
    K = LSM
    ElseIf j > LSC Then
    ' end of leftmost possible match is past end of StringCheck!
    Exit Do
    Else
    K = Positions(Asc(Mid$(StringCheck, j, 1)))
    End If

    If K = 0 Then
    ' end of possible match not within StringMatch at all
    Start = j + LSM
    ElseIf K <> LSM Then
    ' EoPM is some other character within StringMatch
    Start = j + 1
    ElseIf InStr(1, Mid$(StringCheck, i, LSM), StringMatch, Compare) <> 1 Then
    ' the rest of the characters don't match
    Start = j + 1
    Else
    ' we have a match!
    If RCount > UBound(Result) Then ReDim Preserve Result(0 To RCount * 2)
    Result(RCount) = i
    RCount = RCount + 1
    If Limit <> 1 Then Limit = Limit - 1 Else Exit Do
    Start = j + Stride
    End If
    End If
    Loop

    If RCount = 0 Then
    InStrAllEx = Array()
    Else
    ReDim Preserve Result(0 To RCount - 1)
    InStrAllEx = Result
    End If
    End Function

    Here's the InStr-in-a-loop reference version:

    Function InStrAll(ByVal StringCheck As String, ByVal StringMatch As String, _
    Optional ByVal Start As Long = 1, Optional ByVal Limit As Long = -1, _
    Optional ByVal Overlaps As Boolean = True, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Variant

    Dim LSC As Long: LSC = Len(StringCheck)
    Dim LSM As Long: LSM = Len(StringMatch)
    Dim Result() As Long, RCount As Long

    ' greasy Split/Replace compatibility stuff
    If Limit < -1 Or Start < 1 Then
    Err.Raise 5
    ElseIf LSM = 0 Then
    ReDim Result(0 To 0)
    Result(0) = Start
    InStrAll = Result
    Exit Function
    ElseIf LSC = 0 Or Limit = 0 Then
    InStrAll = Array()
    Exit Function
    End If

    If Limit < 1 Or Limit > 1000 Then ReDim Result(0 To 15) _
    Else ReDim Result(0 To Limit - 1)

    Dim Stride As Long: If Overlaps Then Stride = 1 Else Stride = LSM
    Do
    Start = InStr(Start, StringCheck, StringMatch, Compare)
    If Start = 0 Then Exit Do

    If RCount > UBound(Result) Then ReDim Preserve Result(0 To RCount * 2)
    Result(RCount) = Start
    RCount = RCount + 1

    If Limit <> 1 Then Limit = Limit - 1 Else Exit Do
    Start = Start + Stride
    Loop

    If RCount = 0 Then
    InStrAll = Array()
    Else
    ReDim Preserve Result(0 To RCount - 1)
    InStrAll = Result
    End If
    End Function

    Here's the test harness:

    Declare Function timeGetTime Lib "WinMM" () As Long
    Declare Function timeBeginPeriod Lib "WinMM" (ByVal p As Long) As Long
    Declare Function timeEndPeriod Lib "WinMM" (ByVal p As Long) As Long

    Function StringXP(ByVal Number As Long, ByVal What As String) As String
    StringXP = Space$(Number * Len(What))
    Mid$(StringXP, 1) = What
    Mid$(StringXP, Len(What) + 1) = StringXP
    End Function

    Sub InStrTest()
    Dim sc As String: sc = StringXP(1000, "Supercalifragilisticexpialidocious")
    Dim sm As String: sm = "SuperSoaker"
    Mid$(sc, Len(sc) - 100) = "SupersoaKeR"

    Const Compare = vbTextCompare

    timeBeginPeriod 1

    Dim t0 As Long: t0 = timeGetTime
    Dim r0 As Variant: r0 = InStrAllEx(sc, sm, , , , Compare)
    t0 = timeGetTime - t0

    Debug.Print UBound(r0) - LBound(r0) + 1; "matches in"; t0;

    Dim t1 As Long: t1 = timeGetTime
    Dim r1 As Variant: r1 = InStrAll(sc, sm, , , , Compare)
    t1 = timeGetTime - t1

    timeEndPeriod 1

    Debug.Print t1

    Debug.Assert LBound(r0) = LBound(r1) And UBound(r0) = UBound(r1)
    Dim i As Long: For i = LBound(r0) To UBound(r0)
    Debug.Assert r0(i) = r1(i)
    Next
    End Sub

    --
    Joe Foster <mailto:jlfoster%40znet.com> On the cans? <http://www.xenu.net/>
    WARNING: I cannot be held responsible for the above They're coming to
    because my cats have apparently learned to type. take me away, ha ha!



Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
HTML5 Development Center
 
 
FAQ
Latest Articles
Java
.NET
XML
Database
Enterprise
Questions? Contact us.
C++
Web Development
Wireless
Latest Tips
Open Source


   Development Centers

   -- Android Development Center
   -- Cloud Development Project Center
   -- HTML5 Development Center
   -- Windows Mobile Development Center