DominoArea.org [Archive]

Code : Tout sélectionner: Function Split(splitstr As String, delim As String, includeempties As Variant) As Variant Dim words() As String Dim holder As String Dim x As Integer Dim counter As Integer Dim laststop As Integer On Error Goto errorhandler Redim words(0) As String laststop = 1 For x = 0 To (Len(splitstr) - 1) holder = Mid$(splitstr, x + 1, 1) If (x <> 0) Then If (Mid$(splitstr, x, 1) = delim) Then If (includeempties = False) Then laststop = x + 1 Goto getnext End If End If Elseif ((x = 0) And (holder = delim)) Then If (includeempties = False) Then laststop = x + 1 Goto getnext End If End If If (x = Len(splitstr) - 1) Then If (holder = delim) Then words(Ubound(words)) = Mid$(splitstr, laststop, (x + 1) - laststop) laststop = x + 2 Redim Preserve words(Ubound(words) + 1) As String Else words(Ubound(words)) = Mid$(splitstr, laststop, (x + 2) - laststop) laststop = x + 2 Redim Preserve words(Ubound(words) + 1) As String End If Else If (holder = delim) Then If (x <> Len(splitstr) - 1) Then words(Ubound(words)) = Mid$(splitstr, laststop, (x + 1) - laststop) laststop = x + 2 Else words(Ubound(words)) = Mid$(splitstr, laststop, x - (laststop - 1)) End If Redim Preserve words(Ubound(words) + 1) As String End If End If getnext: Next x If (Ubound(words) > 0) Then Redim Preserve words(Ubound(words) - 1) As String Else words(0) = "" End If Split = words Exit Function errorhandler: words(0) = "" Split = words Exit Function End Function

Code : Tout sélectionner: Function chaine_DecouperSelonChaine (sChaineOrigine As String, sChaineRech As String, bVideInclu As Integer) As Variant Dim sTabResult () As String Dim sChaineTraitement As String Dim sMorceau As String Dim iOccurPos As Integer Redim sTabResult (0) sTabResult (0) = "$$Pas Affecte$$" sChaineTraitement = sChaineOrigine iOccurPos = Instr (sChaineTraitement, sChaineRech) While iOccurPos <> 0 sMorceau = Left$ (sChaineTraitement, iOccurPos - 1) sChaineTraitement = Right$ (sChaineTraitement, Len (sChaineTraitement) - (iOccurPos + (Len (sChaineRech) - 1))) If sMorceau <> "" Or bVideInclu Then If Ubound (sTabResult) = 0 And sTabResult (0) = "$$Pas Affecte$$" Then sTabResult (0) = sMorceau Else Redim Preserve sTabResult (Ubound (sTabResult) + 1) sTabResult (Ubound (sTabResult)) = sMorceau End If End If iOccurPos = Instr (sChaineTraitement, sChaineRech) Wend If sChaineTraitement <> "" Or bVideInclu Then If Ubound (sTabResult) = 0 And sTabResult (0) = "$$Pas Affecte$$" Then sTabResult (0) = sChaineTraitement Else Redim Preserve sTabResult (Ubound (sTabResult) + 1) sTabResult (Ubound (sTabResult)) = sChaineTraitement End If End If If sTabResult (0) = "$$Pas Affecte$$" Then sTabResult (0) = "" End If chaine_DecouperSelonChaine = sTabResult End Function

Code : Tout sélectionner: Function Spliting(Byval wSource As String,Byval wnbChar As Integer,Byval wsgWord As Single, wnbSplit As Integer) As Variant 'wtext = text a découper 'wnbChar = nombre maximum de caractère par troncon 'wvrWord = true, ne coupe pas un mot en 2, false, coupe le mot de 2 'nbSplit indique le nombre maximal de ligne retoruné, si zero alors renvoi autant de lighne que nécessaire 'Déclaration des Variables Dim textTempo As String Dim textTempo2 As String Dim lstSplit List As String Dim i As Long Dim J As Long Dim vrValue As Variant On Error Goto ErreurSpliting Erase LstSplit If wSource = "" Then LstSplit(0) = "" Spliting = LstSplit Erase LstSplit Exit Function End If If wnbChar < 1 Then LstSplit(0) = "" Spliting = LstSplit Erase LstSplit Exit Function End If If Len(wSource) <= wnbChar Then LstSplit(0) = wSource Spliting = LstSplit Erase LstSplit Exit Function End If Select Case wsgWord Case True 'avec respect des mots i = 0 TextTempo = wSource While TextTempo<>"" If wnbSplit > 0 Then If i >= wnbSplit Then Spliting = LstSplit Erase LstSplit Exit Function End If End If If (Len(TextTempo)-wnbChar)>0 Then TextTempo2 = Left(TextTempo,wnbChar) TextTempo = Right(TextTempo,Len(TextTempo)-wnbChar) 'détermine si pour le trocon de chaine, le dernier mot est coupé ou entier 'en fonction du premier caratère restant sur le texte d'origine à découpé Select Case Left(TextTempo,1) Case " ",Chr(9),Chr(10),Chr(13) 'le mot est entier aucun traitement à faire ! Case Else 'le mot n'est pas entier vrValue = False J = Len(TextTempo2) 'recherche du prochain caratère de séparation de mot While vrValue = False Select Case Mid(TextTempo2,J,1) Case " ",Chr(9),Chr(10),Chr(13) vrValue = True Case Else J = J-1 If J = 0 Then vrValue = True End If End Select Wend End Select 'si J = 0 c'est que le troncon ne comporte pas d'espace If J = 0 Then LstSplit(i) = TextTempo2 Else LstSplit(i) = Left(TextTempo2,J) TextTempo = Right(TextTempo2,Len(TextTempo2)-J) + TextTempo End If TextTempo2 = "" J = 0 Else LstSplit(i) = TextTempo TextTempo = "" End If i = i + 1 Wend Case False ' sans respect des mots i = 0 TextTempo = wSource While TextTempo<>"" If wnbSplit > 0 Then If i >= wnbSplit Then Spliting = LstSplit Erase LstSplit Exit Function End If End If If (Len(TextTempo)-wnbChar)>0 Then 'détermin e si la taille du texte a découpé est supérieur a la longeur maximal LstSplit(i) = Left(TextTempo,wnbChar) TextTempo = Right(TextTempo,Len(TextTempo)-wnbChar) Else ' si la taill est inférieur alors on est arrivé a la fin du découpage ! LstSplit(i) = TextTempo TextTempo = "" End If i = i + 1 Wend End Select i = 0 J = 0 TextTempo = "" TextTempo2 = "" Spliting = LstSplit Erase LstSplit Exit Function ErreurSpliting: Msgbox "(Spliting) Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !" LstSplit(0) = "" Spliting = LstSplit Exit Function End Function

DominoArea.org [Archive]

Découper une chaine (Split)

Découper une chaine (Split)

Le @explode en version rapide.