Découper une chaine (Split)

[oguruma]

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


[Ex Stagiaire]

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

[Michael DELIQUE]

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