MultiInStr (Update Nov 7, 2009)

This is an improvement on the MultiInStr function that appears in other peoples code now and again ... I don't know who the original author was, so I hope who-ever you are you don't mind ... The original code would search through a string looking for occurences of single characters, while this pair of functions search for single-or-multi character terms within the given string ... Included are MultiInStr and MultiInStrR functions ... Hope someone finds them useful ... Update 25 May - improved versions added thanks to contributions from Kenneth Buckmaster ... Update 7 Nov - Reset string len bug fix in Ken's MultiInStr ... Happy coding

Original Author: Rde

Code


 


 '---------------------------------

 

 ' Simple MultiInStr:

 ' Always returns 'their' before 'heir'

 ' but returns either 'the' or 'their' depending on

 ' which term was found first in sTerms array order


 

Function MultiInStr(sSrc As String, sTerms() As String, _

                    Optional ByVal lStart As Long = 1, _

                    Optional ByVal eCompare As VbCompareMethod = vbBinaryCompare, _

                    Optional ByVal lRightLimit As Long = -1, _

                    Optional ByRef lHitItemIndex As Long) As Long

  Dim iPos As Long

  Dim iHit As Long

  Dim iIdx As Long

 

  If lRightLimit = -1 Then lRightLimit = Len(sSrc)

  iHit = Len(sSrc) + 1

 

  For iIdx = LBound(sTerms) To UBound(sTerms)

     iPos = InStr(lStart, sSrc, sTerms(iIdx), eCompare)

     If iPos Then

        If iPos < iHit Then iHit = iPos: lHitItemIndex = iIdx

     End If

  Next

 

  If iHit < Len(sSrc) + 1 Then MultiInStr = iHit

 

End Function

 


 '---------------------------------

 

 ' Comment From: Kenneth Buckmaster

 ' It occurred to me that you could avoid searching the

 ' whole string length after a term is found

 

 ' Also added something you might want in these functions -

 ' returns 'the' before 'their' when in the same location


 

Private Declare Sub CopyMemory Lib
"kernel32" Alias "RtlMoveMemory" _

                   (pDest
As Any, pSrc As Any, ByVal lLenB As Long)

 

Function MultiInStr(sSrc As String, sTerms() As String, _

                    Optional ByVal lStart As Long = 1, _

                    Optional ByVal eCompare As VbCompareMethod = vbBinaryCompare, _

                    Optional ByVal lRightLimit As Long = -1, _

                    Optional ByRef lHitItemIndex As Long) As Long ' Kenneth Buckmaster

  Dim iPos As Long

  Dim iHit As Long

  Dim iIdx As Long

 

  Dim spointer As Long

  Dim slenb As Long

  Dim biggestlen As Long

  Dim newsearchlen As Long

 

  Dim bHit As Boolean

 

  slenb = LenB(sSrc)

  spointer = StrPtr(sSrc) - 4&

 

  For iIdx = LBound(sTerms) To UBound(sTerms)

     If LenB(sTerms(iIdx)) > biggestlen Then biggestlen = LenB(sTerms(iIdx))

  Next

 

  If lRightLimit = -1 Then lRightLimit = Len(sSrc)

  iHit = Len(sSrc) + 1

 

  For iIdx = LBound(sTerms) To UBound(sTerms)

     iPos = InStr(lStart, sSrc, sTerms(iIdx), eCompare)

 

     If iPos Then

        If iPos < iHit Then

            bHit = True

        ElseIf iPos = iHit Then

            bHit = LenB(sTerms(iIdx)) < LenB(sTerms(lHitItemIndex))

        End If

 

        If bHit Then

            iHit = iPos

            lHitItemIndex = iIdx

            newsearchlen = iHit + iHit + biggestlen

            If newsearchlen < slenb Then

                CopyMemory ByVal spointer, newsearchlen, 4&

            End If

            bHit = False

        End If

     End If

  Next

 

  CopyMemory ByVal spointer, slenb, 4&

 

  If iHit < Len(sSrc) + 1 Then MultiInStr = iHit

 

End Function

 


 '---------------------------------

 

 ' Simple MultiInStrR:

 ' Returns 'heir' before 'their' for reverse search

 ' but returns either 'the' or 'their' depending on

 ' which term was found first in sTerms array order


 

Function MultiInStrR(sSrc As String, sTerms() As String, _

                     Optional ByVal lRightStart As Long = -1, _

                     Optional ByVal eCompare As VbCompareMethod = vbBinaryCompare, _

                     Optional ByVal lLeftLimit As Long = 1, _

                     Optional ByRef lHitItemIndex As Long) As Long

  Dim iLast As Long

  Dim iPos As Long

  Dim iHit As Long

  Dim iIdx As Long

 

  If lRightStart = -1 Then lRightStart = Len(sSrc)

 

  For iIdx = LBound(sTerms) To UBound(sTerms)

     iPos = InStr(lLeftLimit, sSrc, sTerms(iIdx), eCompare)

 

     Do Until iPos = 0 Or iPos > lRightStart

        iLast = iPos

        iPos = InStr(iLast + 1, sSrc, sTerms(iIdx), eCompare)

     Loop

 

     If iLast > iHit Then

        iHit = iLast

        lHitItemIndex = iIdx

        lLeftLimit = iLast

        iLast = 0

     End If

  Next

 

  If iHit Then MultiInStrR = iHit

 

End Function

 


 '---------------------------------

 

 ' Comment From: Kenneth Buckmaster

 ' Always returns 'heir' before 'their' for reverse search

 ' Always returns 'their' before 'the' for reverse search


 


Function MultiInStrR(sSrc As String, sTerms() As String, _

                     Optional ByVal lRightStart As Long = -1, _

                     Optional ByVal eCompare As VbCompareMethod = vbBinaryCompare, _

                     Optional ByVal lLeftLimit As Long = 1, _

                     Optional ByRef lHitItemIndex As Long) As Long ' Kenneth Buckmaster

  Dim iLast As Long

  Dim iPos As Long

  Dim iHit As Long

  Dim iIdx As Long

 

  Dim bHit As Boolean

 

  If lRightStart = -1 Then lRightStart = Len(sSrc)

 

  For iIdx = LBound(sTerms) To UBound(sTerms)

     iPos = InStr(lLeftLimit, sSrc, sTerms(iIdx), eCompare)

 

     Do Until iPos = 0 Or iPos > lRightStart

        iLast = iPos

        iPos = InStr(iLast + 1, sSrc, sTerms(iIdx), eCompare)

     Loop

 

     If iLast > iHit Then

        bHit = True

     ElseIf iLast = iHit Then

        bHit = LenB(sTerms(iIdx)) > LenB(sTerms(lHitItemIndex))

     End If

 

     If bHit Then

        iHit = iLast

        lHitItemIndex = iIdx

        lLeftLimit = iLast

        iLast = 0

        bHit = False

     End If

  Next

 

  If iHit Then MultiInStrR = iHit

 

End Function