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
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.