OPÉRATIONS SUR LES CHAINES DE CARACTÈRE OPTIMISÉES ET ÉTENDUES

Option Explicit

' Modules de fonctions pour agir sur les strings optimisées
' Fonctions extraites de : http://xbeat.net/vbspeed/

Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&)

Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" (ByVal Addr As Long, Source As Long, _
                        Optional ByVal Bytes As Long = 4)

Private Declare Function SysAllocStringByteLen Lib "oleaut32" _
                        (ByVal lpstr As Long, ByVal ByteLen As Long) As Long
Private Declare Function VarPtrArray& Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any)
Private Declare Function ArrPtr& Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any)
Private Declare Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes&)
Private Type SAFEARRAY1D
    cDims           As Integer
    fFeatures       As Integer
    cbElements      As Long
    cLocks          As Long
    pvData          As Long
    cElements       As Long
    lLbound         As Long
End Type


' Crée une chaine de caractère (comme Space() ou String())
Public Function StrAlloc(ByVal lSize As Long) As String
    ' by Jory, jory@joryanick.com, 20011023
    RtlMoveMemory ByVal VarPtr(StrAlloc), _
            SysAllocStringByteLen(0&, lSize + lSize), 4&
End Function


' Equivalent à StrComp()
Public Function StrCompare(String1 As String, String2 As String, Optional Compare As VbCompareMethod = vbBinaryCompare) As Boolean
' by Donald, donald@xbeat.net, 20001012, rev 001 20040813
    If LenB(String1) = LenB(String2) Then
        If Compare = vbBinaryCompare Then
            If LenB(String1) = 0 Then
                StrCompare = True
            Else
                StrCompare = (InStrB(1, String1, String2, Compare) <> 0)
            End If
        Else
            StrCompare = (StrComp(String1, String2, Compare) = 0)
        End If
    End If
End Function


' LCase
Public Function StrLCase(ByRef sString As String) As String
' by Donald, donald@xbeat.net, 20011209
    Static saDst As SAFEARRAY1D
    Static aDst%()
    Static pDst&, psaDst&
    Static init As Long
    Dim c As Long
    Dim lLen As Long
    Static iLUT(0 To 400) As Integer
    If init Then
    Else
        saDst.cDims = 1
        saDst.cbElements = 2
        saDst.cElements = &H7FFFFFFF
        pDst = VarPtr(saDst)
        psaDst = ArrPtr(aDst)
        ' init LUT
        For c = 0 To 255: iLUT(c) = AscW(LCase$(Chr$(c))): Next
        For c = 256 To 400: iLUT(c) = c: Next
        iLUT(352) = 353
        iLUT(338) = 339
        iLUT(381) = 382
        iLUT(376) = 255
        init = 1
    End If
    lLen = Len(sString)
    RtlMoveMemory ByVal VarPtr(StrLCase), _
        SysAllocStringByteLen(StrPtr(sString), lLen + lLen), 4
    saDst.pvData = StrPtr(StrLCase)
    RtlMoveMemory ByVal psaDst, pDst, 4
    For c = 0 To lLen - 1
      Select Case aDst(c)
      Case 65 To 381
        aDst(c) = iLUT(aDst(c))
      End Select
    Next
    RtlMoveMemory ByVal psaDst, 0&, 4
End Function


' UCase
Public Function StrUCase(ByRef sString As String) As String
' by Donald, donald@xbeat.net, 20011209
    Static saDst As SAFEARRAY1D
    Static aDst%()
    Static pDst&, psaDst&
    Static init As Long
    Dim c As Long
    Dim lLen As Long
    Static iLUT(0 To 400) As Integer
    If init Then
    Else
        saDst.cDims = 1
        saDst.cbElements = 2
        saDst.cElements = &H7FFFFFFF
        pDst = VarPtr(saDst)
        psaDst = ArrPtr(aDst)
        For c = 0 To 255: iLUT(c) = AscW(UCase$(Chr$(c))): Next
        For c = 256 To 400: iLUT(c) = c: Next
        iLUT(353) = 352
        iLUT(339) = 338
        iLUT(382) = 381
        init = 1
    End If
    lLen = Len(sString)
    RtlMoveMemory ByVal VarPtr(StrUCase), _
        SysAllocStringByteLen(StrPtr(sString), lLen + lLen), 4
    saDst.pvData = StrPtr(StrUCase)
    RtlMoveMemory ByVal psaDst, pDst, 4
    For c = 0 To lLen - 1
      Select Case aDst(c)
      Case 97 To 382
        aDst(c) = iLUT(aDst(c))
      End Select
    Next
    RtlMoveMemory ByVal psaDst, 0&, 4
End Function


' Returns a string where multiple adjacent occurrences of a specified
' substring are compressed to just one occurrence.
' StrCompress("abbbbcba", "b") => "abcba"
'   sExpression Required. String expression containing substring sequences to be compressed.
'   sCompress   Required. The single string whereof sequences are to be compressed.
'   Compare Optional. Numeric value indicating the kind of comparison to use when evaluating substrings.
'       If omitted, the default value is 0, which means a binary comparison is performed.
Public Function StrCompress( _
            sExpression As String, _
            sCompress As String, _
            Optional Compare As VbCompareMethod = vbBinaryCompare) As String
' by Tom Winters, tom@interplanetary.freeserve.co.uk, 20011104
    Dim sExp$, sFind$, lLenCompress&, lLenExpression&
    Dim lChrPosition&
    lLenExpression = Len(sExpression)
    If lLenExpression = 0 Then Exit Function
    lLenCompress = Len(sCompress)
    If lLenCompress <> 0 Then
        If lLenCompress = 1 Then
            If lLenExpression < 10 Then
            sFind = sCompress + sCompress
                StrCompress = sExpression
                Do
                    lChrPosition = InStr(1, StrCompress, sFind, Compare)
                    If lChrPosition = 0 Then Exit Function
                    sExp = Left$(StrCompress, lChrPosition)
                    StrCompress = Right$(StrCompress, Len(StrCompress) - _
                                                                Len(sExp) - lLenCompress)
                    StrCompress = sExp + StrCompress
                Loop
            Else
                Dim sNewSearchString$
                sExp = Left$(sExpression, 12)
                sNewSearchString = String$(8, sCompress)
                lChrPosition = InStr(1, sExp, sNewSearchString, Compare)
                If lChrPosition > 0 Then
                    Dim lLenNewSearchString&, lLenFind2&, lStringSizeCounter&
                    lLenFind2 = lLenCompress + lLenCompress
                    lStringSizeCounter = (lLenExpression - lLenFind2)
                    lStringSizeCounter = lStringSizeCounter + (lStringSizeCounter And 1)
                    sNewSearchString = String$(lStringSizeCounter, sCompress)
                    lLenNewSearchString = Len(sNewSearchString)
                    lStringSizeCounter = 0
                    StrCompress = sExpression
                    sFind = sCompress + sCompress
                    Do
                        Do
                            lChrPosition = InStr(1, StrCompress, sNewSearchString, Compare)
                            If lChrPosition = 0 Then Exit Do
                            sExp = Left$(StrCompress, lChrPosition)
                            StrCompress = Right$(StrCompress, Len(StrCompress) _
                                          - Len(sExp) - lLenNewSearchString + lLenCompress)
                            StrCompress = sExp + StrCompress
                            lStringSizeCounter = 0
                        Loop
                        lChrPosition = InStr(1, StrCompress, sFind, Compare)
                        If lChrPosition = 0 Then Exit Function
                        lStringSizeCounter = lStringSizeCounter + lLenCompress
                        sNewSearchString = Right$(sNewSearchString, Len(StrCompress) _
                                                                      - lStringSizeCounter)
                        lLenNewSearchString = Len(sNewSearchString)
                    Loop
                End If
            End If
        End If
        Dim lCharacter&, lAsciiValue&
        For lCharacter = 1 To lLenCompress
            lAsciiValue = Asc(Mid$(sCompress, lCharacter, 1))
            If lAsciiValue > 127 Then
                Dim bGo As Boolean, lPosition&
                sExp = sExpression
                Do While Len(sExp) > 0
                    bGo = False
                    lPosition = InStr(1, sExp, sCompress, Compare)
                    If Mid$(sExp, lPosition + lLenCompress, lLenCompress) = sCompress Then
                        If lPosition = 1 Then
                            bGo = True
                        End If
                    End If
                    If bGo Then
                        sExp = Right$(sExp, Len(sExp) - lLenCompress)
                    Else
                        StrCompress = StrCompress + Left$(sExp, 1)
                        sExp = Right$(sExp, Len(sExp) - 1)
                    End If
                Loop
                Exit Function
            End If
        Next
        Dim bMatch As Boolean, bMatchResult1 As Boolean, bMatchResult2 As Boolean
        Dim lLenExpressionArray&, lLenCompressArray&, lbytePosition&, lNewCounter&
        Dim byExpressionArray() As Byte, byNewArray() As Byte, byCompressArray() As Byte
        Dim lNearEndofExpression&, lExpCounter&, lLenCompressArrayplus1&
        If Compare = vbTextCompare Then
            sExpression = LCase$(sExpression)
            sCompress = LCase$(sCompress)
        End If
        byExpressionArray = sExpression
        byCompressArray = sCompress
        lLenExpressionArray = lLenExpression + lLenExpression - 1
        lLenCompressArray = lLenCompress + lLenCompress - 1
        ReDim byNewArray(lLenExpressionArray)
        lNewCounter = 0
        bMatch = Left$(sExpression, 1) = sCompress
        If Not bMatch And (lLenCompressArray = 1) Then
            For lbytePosition = 1 To lLenExpressionArray
                lbytePosition = lbytePosition - 1
                If byExpressionArray(lbytePosition) <> byCompressArray(0) Then
                    byNewArray(lNewCounter) = byExpressionArray(lbytePosition)
                    lNewCounter = lNewCounter + 2
                Else
                    If byExpressionArray(lbytePosition - 2) <> byCompressArray(0) Then
                        byNewArray(lNewCounter) = byCompressArray(0)
                        lNewCounter = lNewCounter + 2
                    End If
                End If
                lbytePosition = lbytePosition + 2
            Next
        Else
            lNewCounter = 0
            lLenCompressArrayplus1 = lLenCompressArray + 1
            lNearEndofExpression = lLenExpressionArray - (lLenCompressArray - 1)
            bMatchResult1 = True
            For lbytePosition = 1 To lLenCompressArrayplus1
                lbytePosition = lbytePosition - 1
                bMatchResult2 = byExpressionArray(lbytePosition) = byCompressArray(lbytePosition)
                bMatchResult1 = bMatchResult1 And bMatchResult2
                If Not bMatchResult1 Then
                    lNewCounter = 0
                    Exit For
                End If
                byNewArray(lNewCounter) = byCompressArray(lbytePosition)
                lNewCounter = lNewCounter + 2
                lbytePosition = lbytePosition + 2
            Next
            For lExpCounter = 1 To lLenExpressionArray
                lExpCounter = lExpCounter - 1
                bMatch = False
                If lExpCounter < lNearEndofExpression Then
                    bMatch = True
                    For lbytePosition = 1 To lLenCompressArray
                        lbytePosition = lbytePosition - 1
                        bMatchResult2 = byExpressionArray(lExpCounter + lbytePosition) _
                                                            = byCompressArray(lbytePosition)
                        bMatch = bMatch And bMatchResult2
                        lbytePosition = lbytePosition + 2
                    Next
                End If
                If Not bMatch Then
                    byNewArray(lNewCounter) = byExpressionArray(lExpCounter)
                    lNewCounter = lNewCounter + 2
                    lExpCounter = lExpCounter + 2
                ElseIf Not bMatchResult1 Then
                    For lbytePosition = 1 To lLenCompressArray
                        lbytePosition = lbytePosition - 1
                        byNewArray(lNewCounter) = byCompressArray(lbytePosition)
                        lNewCounter = lNewCounter + 2
                        lExpCounter = lExpCounter + 2
                        lbytePosition = lbytePosition + 2
                    Next
                Else
                    lExpCounter = lExpCounter + lLenCompressArrayplus1
                End If
                bMatchResult1 = bMatch
            Next
        End If
        StrCompress = byNewArray
        StrCompress = Left$(StrCompress, lNewCounter * 0.5)
        Exit Function
    Else
        StrCompress = sExpression
    End If
End Function


' Renvoie l'extension d'un fichier
' Exemple : StrGetExtension("c:\dir\file.txt") renvoie "txt"
Public Function StrGetExtension(sFile As String) As String
' by Peter Weighill, pweighill@btinternet.com, 20001021
' Only for VB6
    Dim iPos As Long
    ' search last dot
    iPos = InStrRev(sFile, ".", -1, vbBinaryCompare)
    If iPos > 0 Then
        If InStr(iPos + 1, sFile, "\", vbBinaryCompare) = 0 Then
            StrGetExtension = Mid$(sFile, iPos + 1)
        End If
    End If
End Function


' Renvoie le nom du fichier du chemin d'accès complet
' Exemple : StrGetFile("c:\dir\file.txt") renvoie "file.txt"
Public Function StrGetFile(sFile As String) As String
' by Peter Weighill, pweighill@btinternet.com, 20001020
' Only for VB6
    Dim iPos As Long
    ' search last backslash
    iPos = InStrRev(sFile, "\", -1, vbBinaryCompare)
    If iPos > 0 Then
        StrGetFile = Mid$(sFile, iPos + 1)
    Else
        StrGetFile = sFile
    End If
End Function


' Renvoie le nom du fichier du chemin d'accès complet
' Exemple : StrGetPath("c:\dir\file.txt") renvoie "c:\dir\"
Public Function StrGetPath(sFile As String) As String
' by Peter Weighill, pweighill@btinternet.com, 20001020
' Only for VB6
    Dim iPos As Long
    ' search last backslash
    iPos = InStrRev(sFile, "\", -1, vbBinaryCompare)
    If iPos > 0 Then
        StrGetPath = Left$(sFile, iPos)
    Else
        StrGetPath = sFile
    End If
End Function


' Returns a zero-based, one-dimensional array containing a specified number of substrings.
'   Expression  Required. String expression containing substrings and delimiters.
'   asToken()   Required. One-dimensional string array that will hold the returned substrings.
'   Delimiters  Required. String containing a sequence of delimiter characters
'               used to identify substring limits.
'   IncludeEmpty    Optional. Boolean flag: if True, zero-length tokens are returned, too.
'               Is False by default, which means that adjoining delimiter chars count as one.
'   Return : Ubound(asToken), or -1 if asToken is empty
' Example :
'   lRet = Tokenize("http://www.xbeat.net/vbspeed/index.htm", asToken, "/.:")
'   count tokens: lRet + 1 = 7
'   asToken elements: "http", "www", "xbeat", "net", "vbspeed", "index", "htm"
Public Function StrTokenize&(Expression$, ResultTokens$(), Delimiters$, Optional IncludeEmpty As Boolean)
' Tokenize02 by Donald, donald@xbeat.net
' modified by G.Beckmann, G.Beckmann@NikoCity.de
    Const ARR_CHUNK& = 1024
    Dim cExp&, ubExpr&
    Dim cDel&, ubDelim&
    Dim aExpr%(), aDelim%()
    Dim sa1 As SAFEARRAY1D, sa2 As SAFEARRAY1D
    Dim cTokens&, iPos&
    ubExpr = Len(Expression)
    ubDelim = Len(Delimiters)
    sa1.cbElements = 2:     sa1.cElements = ubExpr
    sa1.cDims = 1:          sa1.pvData = StrPtr(Expression)
    RtlMoveMemory ByVal VarPtrArray(aExpr), VarPtr(sa1), 4
    sa2.cbElements = 2:     sa2.cElements = ubDelim
    sa2.cDims = 1:          sa2.pvData = StrPtr(Delimiters)
    RtlMoveMemory ByVal VarPtrArray(aDelim), VarPtr(sa2), 4
    If IncludeEmpty Then
        ReDim Preserve ResultTokens(ubExpr)
    Else
        ReDim Preserve ResultTokens(ubExpr \ 2)
    End If
    ubDelim = ubDelim - 1
    For cExp = 0 To ubExpr - 1
        For cDel = 0 To ubDelim
            If aExpr(cExp) = aDelim(cDel) Then
                If cExp > iPos Then
                    ResultTokens(cTokens) = Mid$(Expression, iPos + 1, cExp - iPos)
                    cTokens = cTokens + 1
                ElseIf IncludeEmpty Then
                    ResultTokens(cTokens) = vbNullString
                    cTokens = cTokens + 1
                End If
                iPos = cExp + 1
                Exit For
            End If
        Next cDel
    Next cExp
    If (cExp > iPos) Or IncludeEmpty Then
        ResultTokens(cTokens) = Mid$(Expression, iPos + 1)
        cTokens = cTokens + 1
    End If
    If cTokens = 0 Then
        Erase ResultTokens()
    Else
        ReDim Preserve ResultTokens(cTokens - 1)
    End If
    StrTokenize = cTokens - 1
    RtlZeroMemory ByVal VarPtrArray(aExpr), 4
    RtlZeroMemory ByVal VarPtrArray(aDelim), 4
End Function


' Returns a pattern replicated in a string a specified number of times.
' Comes down to an enhanced version of VB's native String$ function,
' that does not allow more than one character to be repeated.
' Example :
'   StrReplicate(3, "abc") => "abcabcabc"
Public Function StrReplicate(ByVal Number As Long, ByRef Pattern As String) As String
' by Nick Paldino, nicholas.paldino@exisconsulting.com, 20001206, rev 001 20011123
    If (Number > 0) Then
        Dim plngPatternLength As Long
        plngPatternLength = LenB(Pattern)
        StrReplicate = Space$(Number * Len(Pattern))
        Dim plngBytesCopied As Long, plngBytesLeft As Long
        plngBytesLeft = LenB(StrReplicate)
        Dim plngSourcePointer As Long, plngDestPointer As Long, plngOriginalDestPointer As Long
        plngSourcePointer = StrPtr(Pattern)
        plngOriginalDestPointer = StrPtr(StrReplicate)
        plngDestPointer = plngOriginalDestPointer
        RtlMoveMemory plngDestPointer, plngSourcePointer, plngPatternLength
        plngBytesLeft = plngBytesLeft - plngPatternLength
        plngBytesCopied = plngPatternLength
        plngDestPointer = plngDestPointer + plngPatternLength
        Do While (plngBytesCopied < plngBytesLeft)
            RtlMoveMemory plngDestPointer, plngOriginalDestPointer, plngBytesCopied
            plngBytesLeft = plngBytesLeft - plngBytesCopied
            plngDestPointer = plngDestPointer + plngBytesCopied
            plngBytesCopied = plngBytesCopied * 2
        Loop
        RtlMoveMemory plngDestPointer, plngOriginalDestPointer, plngBytesLeft
    End If
End Function


' Replace
Public Function StrReplace(ByRef Text As String, _
        ByRef sOld As String, ByRef sNew As String, _
        Optional ByVal Start As Long = 1, _
        Optional ByVal Count As Long = 2147483647, _
        Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _
        ) As String
' by Jost Schwider, jost@schwider.de, 20001218
    If LenB(sOld) Then
        If Compare = vbBinaryCompare Then
            StrReplaceBin StrReplace, Text, Text, _
                sOld, sNew, Start, Count
        Else
            StrReplaceBin StrReplace, Text, LCase$(Text), _
                LCase$(sOld), sNew, Start, Count
        End If
    Else
        StrReplace = Text
    End If
End Function
Private Static Sub StrReplaceBin(ByRef result As String, _
    ByRef Text As String, ByRef Search As String, _
    ByRef sOld As String, ByRef sNew As String, _
    ByVal Start As Long, ByVal Count As Long _
  )
' by Jost Schwider, jost@schwider.de, 20001218
    Dim TextLen As Long
    Dim OldLen As Long
    Dim NewLen As Long
    Dim ReadPos As Long
    Dim WritePos As Long
    Dim CopyLen As Long
    Dim Buffer As String
    Dim BufferLen As Long
    Dim BufferPosNew As Long
    Dim BufferPosNext As Long
    If Start < 2 Then
      Start = InStrB(Search, sOld)
    Else
      Start = InStrB(Start + Start - 1, Search, sOld)
    End If
    If Start Then
      OldLen = LenB(sOld)
      NewLen = LenB(sNew)
      Select Case NewLen
      Case OldLen
        result = Text
        For Count = 1 To Count
          MidB$(result, Start) = sNew
          Start = InStrB(Start + OldLen, Search, sOld)
          If Start = 0 Then Exit Sub
        Next Count
        Exit Sub
      Case Is < OldLen
        TextLen = LenB(Text)
        If TextLen > BufferLen Then
          Buffer = Text
          BufferLen = TextLen
        End If
        ReadPos = 1
        WritePos = 1
        If NewLen Then
          For Count = 1 To Count
            CopyLen = Start - ReadPos
            If CopyLen Then
              BufferPosNew = WritePos + CopyLen
              MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
              MidB$(Buffer, BufferPosNew) = sNew
              WritePos = BufferPosNew + NewLen
            Else
              MidB$(Buffer, WritePos) = sNew
              WritePos = WritePos + NewLen
            End If
            ReadPos = Start + OldLen
            Start = InStrB(ReadPos, Search, sOld)
            If Start = 0 Then Exit For
          Next Count
        Else
          For Count = 1 To Count
            CopyLen = Start - ReadPos
            If CopyLen Then
              MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
              WritePos = WritePos + CopyLen
            End If
            ReadPos = Start + OldLen
            Start = InStrB(ReadPos, Search, sOld)
            If Start = 0 Then Exit For
          Next Count
        End If
        If ReadPos > TextLen Then
          result = LeftB$(Buffer, WritePos - 1)
        Else
          MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
          result = LeftB$(Buffer, WritePos + LenB(Text) - ReadPos)
        End If
        Exit Sub
      Case Else
        TextLen = LenB(Text)
        BufferPosNew = TextLen + NewLen
        If BufferPosNew > BufferLen Then
          Buffer = Space$(BufferPosNew)
          BufferLen = LenB(Buffer)
        End If
        ReadPos = 1
        WritePos = 1
        For Count = 1 To Count
          CopyLen = Start - ReadPos
          If CopyLen Then
            BufferPosNew = WritePos + CopyLen
            BufferPosNext = BufferPosNew + NewLen
            If BufferPosNext > BufferLen Then
              Buffer = Buffer & Space$(BufferPosNext)
              BufferLen = LenB(Buffer)
            End If
            MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
            MidB$(Buffer, BufferPosNew) = sNew
          Else
            BufferPosNext = WritePos + NewLen
            If BufferPosNext > BufferLen Then
              Buffer = Buffer & Space$(BufferPosNext)
              BufferLen = LenB(Buffer)
            End If
            MidB$(Buffer, WritePos) = sNew
          End If
          WritePos = BufferPosNext
          ReadPos = Start + OldLen
          Start = InStrB(ReadPos, Search, sOld)
          If Start = 0 Then Exit For
        Next Count
        If ReadPos > TextLen Then
          result = LeftB$(Buffer, WritePos - 1)
        Else
          BufferPosNext = WritePos + TextLen - ReadPos
          If BufferPosNext < BufferLen Then
            MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
            result = LeftB$(Buffer, BufferPosNext)
          Else
            result = LeftB$(Buffer, WritePos - 1) & MidB$(Text, ReadPos)
          End If
        End If
        Exit Sub
      End Select
    Else
      result = Text
    End If
End Sub


' Split
Public Sub StrSplit(Expression$, ResultSplit$(), Optional Delimiter$ = " ")
' by G.Beckmann, G.Beckmann@NikoCity.de
    Dim c&, iLen&, iLast&, iCur&
    iLen = Len(Delimiter)
    If iLen Then
        iCur = InStr(Expression, Delimiter)
        Do While iCur
            iCur = InStr(iCur + iLen, Expression, Delimiter)
            c = c + 1
        Loop
        ReDim Preserve ResultSplit(0 To c)
        c = 0: iLast = 1
        iCur = InStr(Expression, Delimiter)
        Do While iCur
            ResultSplit(c) = Mid$(Expression, iLast, iCur - iLast)
            iLast = iCur + iLen
            iCur = InStr(iLast, Expression, Delimiter)
            c = c + 1
        Loop
        ResultSplit(c) = Mid$(Expression, iLast)
    Else
        ReDim Preserve ResultSplit(0 To 0)
        ResultSplit(0) = Expression
    End If
End Sub


' Word count
' Counts the words found within a given text string.
' Words are delimited by white space (blanks, tabs, carriage returns, line feeds, nullchars, etc...)
' Let's keep it simple: white space is ASCII 0 thru 32.
Public Function StrWordCount(ByRef sText As String) As Long
' by Jost Schwider, jost@schwider.de, http://vb-tec.de/, 20011120
    Static Chars() As Integer
    Static Pointer As Long
    Dim i As Long
    If Pointer = 0& Then
        ReDim Chars(1& To 1&)
        PokeLng VarPtr(Pointer), ByVal ArrPtr(Chars)
        PokeLng Pointer + 16&, &H7FFFFFFF
        Pointer = Pointer + 12&
    End If
    PokeLng Pointer, StrPtr(sText)
    For i = 1& To Len(sText)
        If Chars(i) > 32 Then
            StrWordCount = StrWordCount + 1&
            Do
                i = i + 1&
            Loop Until Chars(i) < 33
        End If
    Next i
End Function