Opérations sur les chaines de caractère optimisées et étendues

Télécharger le projet
Commenter

Description

Bonjour à tous,

Voici un module regroupant un paquet de fonctions permettant des opérations sur les chaines de caractère TRÈS optimisées !

/!\
Je ne suis l'auteur d'aucune de ces fonctions (vous verrez c'est du VB de haut vol)
/!\

Liste des fonctions (et les fonctions VB qu'elles remplacent) :
- StrAlloc (= Space() ou String)
- StrCompare (= StrComp ou str1 = str2)
- StrLCase (= LCase)
- StrUCase (= UCase)
- StrCompress (StrCompress("abbbbcba", "b") => "abcba")
- StrGetExtension (StrGetExtension("c:\dir\file.txt") renvoie "txt")
- StrGetFile (StrGetFile("c:\dir\file.txt") renvoie "file.txt")
- StrGetPath (StrGetPath("c:\dir\file.txt") renvoie "c:\dir\")
- StrTokenize (Split mais avec plusieurs séparateurs)
- StrReplicate (StrReplicate(3, "abc") => "abcabcabc")
- StrReplace (Replace)
- StrSplit (Split)
- StrWordCount (Nombre de mots)

Ces fonctions ont été l'objet de très fortes optimisations et de benchmarking. Elles ont toutes été trouvées sur le très bon site :
http://xbeat.net/vbspeed/

Je me suis contenté de rassembler ces fonctions dans un module, de choisir les meilleures (pas toujours les + rapides), de les renommer et de commenter leur en tête (ce qui m'a quand même pris un après-midi).

Critères de choix :
- De préférence les plus rapides
- Pas de classes (tout doit tenir dans un module)
- Pas de TLB (tout dans un module, et c'est tout)
- Respect strict des spécifications VB (comportement identique qu'une fonction VB)

À cause de ces critères de choix, il se peut que je n'utilise pas la fonction la plus rapide, mais c'est une version stable, facile à utiliser.

J'ai viré tous les commentaires DANS les fonctions pour raccourcir le code, ce module est une librairie, pour comprendre le code consultez les fonctions originales.

NOTE : Il faut avoir installer le Service Pack 6 pour Visual Basic 6 pour pouvoir profiter de toutes les fonctions

Source / Exemple : 


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

Conclusion :


Merci aux auteurs de ces folles fonctions !
Parfois le gain est incroyable comparé aux fonctions natives de VB, et les fonctions ajoutées sont très utiles.

Lien vers le site :
http://xbeat.net/vbspeed/

NOTE : Il faut avoir installer le Service Pack 6 pour Visual Basic 6 pour pouvoir profiter de toutes les fonctions

MadMatt
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (MadM@tt)