Fonction personnelle pour diviser un texte en plusieurs contenus

**chrisaccess** · 30/03/2017, 16h22

Bonjour,

J'utilise au travail un petit programme me permettant de saisir dans un commentaires la liste d'actions que j'ai réalisé.
Ce commentaire est limité en nombre de caractère (250)
Je cherche depuis un moment à réaliser une fonction qui permette à stocker dans le presse papier le contenu d'une variable et de le décomposer en plusieurs commentaires de - de 250 caractères.
Par principe j'utilise une fonction personnelle qui coupe à partir de 224 caractères au premier espace disponible.
J'ai définit 10 commentaires possibles.

Ma première fonction fonctionne très bien jusqu'à 2 commentaires mais elle déconne après, dont en voici le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
Sub contactosr(interloc As String, contenu As String)
 
a = Len(contenu) 'compte le nombre de caractère du contact - max 250
 
If a > 249 Then
 
    liste = contacts(contenu)
    b = liste(1)
    For c = 1 To b
        d = c + 1
 
        inter1 = interloc & " " & c & "/" & b ' interlocuteur et ajouter numero / nombre de contacts
        MyData.SetText inter1
        MyData.PutInClipboard
        Load contact
            contact.Image3.Visible = True
            contact.Label1.Visible = True
            contact.Label5.Caption = inter1
        contact.Show vbModal
 
        Unload contact
 
        MyData.SetText liste(d)
        MyData.PutInClipboard
 
        Load contact
            contact.Image2.Visible = True
            contact.Label2.Visible = True
            contact.Label5.Caption = liste(d)
        contact.Show vbModal
 
        Unload contact
    Next c
 
Else
 
    MyData.SetText interloc
    MyData.PutInClipboard
    Load contact
        contact.Image3.Visible = True
        contact.Label1.Visible = True
        contact.Label5.Caption = interloc
    contact.Show vbModal
 
    Unload contact
 
    MyData.SetText contenu
    MyData.PutInClipboard
    Load contact
        contact.Image2.Visible = True
        contact.Label2.Visible = True
        contact.Label5.Caption = contenu
    contact.Show vbModal
 
    Unload contact
 
End If
 
End Sub
 
Function contacts(contens As String)
 
    '************************* LIMITER A 10 CONTACTS ***************************************
       '------- procedure pour scinder la requete -------------
    'La chaine sera scindée si sa longueur est supérieure à 80 caractères
    Dim requete(10) As String
    Dim compteu As Integer
    Dim compter As Integer
    Dim nombcont As Single
    Dim debut As Integer
    Dim debus As Integer
 
 
    If Len(contens) > 249 Then
        nombcont = (Len(contens) / 250)                                 'nombre de contacts
        If nombcont > Int(nombcont) Then nombcont = Int(nombcont) + 1   'arrondi au nombre supérieur si résultat division pas un nombre entier
        requete(1) = nombcont                                           'rentre dans le 1er argument le nombre de contact
        debut = InStr(224, contens, " ")                                'définit la fin du contact
        requete(2) = Left(contens, debut)                               'récupère le 1 er contact
        If nombcont > 1 Then
            For compteu = 2 To nombcont                                 'boucle enregistre les autres contact de 2 à infini
                compter = compteu + 1
                fin = debut + 224
                fin = InStr(fin, contens, " ")
                If fin = 0 Then fin = Len(contens)
                requete(compter) = Mid(contens, debut, fin)
                debut = debut + fin
            Next compteu
        End If
    End If
    contacts = requete
 
End Function

J'ai réécrit le module "contacts" qui est celui qui pose problème.

En voici le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Function contacts(contens As String)
 
    '************************* LIMITER A 10 CONTACTS ***************************************
       '------- procedure pour scinder la requete -------------
    'La chaine sera scindée si sa longueur est supérieure à 249 caractères
    Dim requete(10) As String
    Dim compteu As Integer
    Dim compter As Integer
    Dim nombcarac As Single
    Dim debut As Integer
    Dim debus As Integer
 
 
nombcarac = Len(contens)
If nombcarac > 249 Then
    requete(1) = 1                                          'rentre dans le 1er argument le nombre de contact
    debut = InStr(224, contens, " ")
    requete(2) = Left(contens, debut)
    If debut < nombcarac Then
        For compteu = 2 To 10                               'boucle enregistre les autres contact de 2 à 10
            compter = compteu + 1
            If debut + 249 > nombcarac Then                 'Création dernier contact et sorti de la boucle une fois tout le texte passé
                requete(compter) = Mid(contens, debut, nombcarac)
                requete(1) = compteu
                Exit For
            Else
                fin = InStr(debut + 224, contens, " ")          'recherche le numéro de lettre du point de sorti du contact
                requete(compter) = Mid(contens, debut, fin)     'saisi dans variable requete le texte
                requete(1) = compteu                            'augmente de +1 le nombre de contacts
                debut = fin                                     'saisi le numéro point de départ du prochain contact
                fin = 0
            End If
        Next compteu
    End If
End If
 
contacts = requete
 
End Function

Mon soucis est que l'avant dernier commentaires copie l'ensemble du texte restant.
Pourtant mon code fonctionne. J'ai surveillé les variables qui comptabilisent les données.

Voici le texte que j'ai utilisé pour mon essai :

"ce jour sans mesure cette infinité de possibilités de colères de mensonges et cette avalanche d'amours qui ne cesse de tarabuster les pirates sont de sortie et pourtant il paraît que ce n'est pas l'issue la plus secourable peut-on pourra-t-on un jour en finir dans la poussière des carlingues la rouille des guimbardes des tréteaux interminables comme ce très long texte où personne ne voit du feu où personne ne voit goutte où personne ne voit clair où il n'y a personne pour sauver son voisin pas un mot pour en rattraper l'autre pas un orgue pour mesurer l'infinité du temps qui passe pas un violon pour nous aider à grimper à la cime des ifs et sur ces dolmens rassemblés comme dans un jeu de cartes un très long texte s'avance et se déploie avec la sûreté pierreuse des dolmens la voilure des stèles la douceur ombrageuse des ifs dont les petites boules rouges d'une netteté aussi sidérante qu'elles sont minuscules sont comme des lampions funèbres un très long texte résonne rebondit ou s'éternise jusqu'à ce que la note tenue sous les ifs comme une mélodie silencieuse effraie même les autours les éperviers et même le busard en maraude à tel point que nous nous retrouvons tous vous et moi à déclamer des lambeaux de ce très long texte debout ou accroupis sur les lourdes pierres qui couvrent depuis des millénaires les"

Il produit 6 contacts.
Observez bien le contenu de chacun des contacts, je retrouve le contenu de la fin du texte dans les 2 derniers contact et je ne comprends pas pourquoi ?

Il faut un forms nommé contact pour faire fonctionner le module "contactosr".
Je peux créer un fichier test et le mettre à disposition si nécessaire.

Merci pour votre aide,

**unparia** · 30/03/2017, 17h26

Bonjur

1) On ne voit nulle part où tu appelles ta fonctions contacts
2) une fonction doit retourner une valeur et donc être typée. Tu n'as pas typée la tienne.

Je n'ai pas analysé ton code (je ne pense pas être là pour corriger).

Je te suggère de regarder ce petit exemple que je viens de bâcler. Il décompose en "tranches" de 20 caractères max en évitant de couper hors des espaces.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Private Sub CommandButton6_Click()
  Dim toto As String, max As Integer, titi
  max = 20
  toto = "ce jour sans mesure cette infinité de possibilités de colères de mensonges et cette avalanche d'amours qui ne cesse de tarabuster aa"
   avanti toto, max, titi
  For i = 0 To UBound(titi)
    MsgBox titi(i)
  Next
End Sub
Private Sub avanti(toto As String, max As Integer, titi)
  tata = toto
  pos = max
  Do While pos < Len(toto)
    If Mid(toto, pos, 1) = " " Then
      Mid(toto, pos, 1) = Chr(1)
    Else
      tata = Left(toto, pos)
      pos = InStrRev(tata, " ")
      Mid(toto, pos, 1) = Chr(1)
    End If
    pos = pos + max + 1
  Loop
  titi = Split(toto, Chr(1))
End Sub

**chrisaccess** · 30/03/2017, 21h43

Envoyé par unparia

Bonjur

1) On ne voit nulle part où tu appelles ta fonctions contacts
2) une fonction doit retourner une valeur et donc être typée. Tu n'as pas typée la tienne.

Bonsoir,

Concernant ton point 1) la sub contactosr appelle ma fonction "contacts" en ligne 3 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

liste = contacts(contenu)

Concernant ton point 2) ma fonction renvoie une valeur tableau de ce type :
contacts(1) : nombre de contacts
contacts(2) : contenu du contact 1
contacts(3) : contenu du contact 2
contacts(4): contenu du contact 3
...
contacts(11) : contenu du contact 10

Ma fonction fonctionne très bien pour les premiers contacts, Mais pour une raison que je n'explique pas l'avant dernier contact contient le texte de l'avant dernier et du dernier contact ?????
Pour être plus clair :
le texte ""ce jour sans mesure cette infinité de possibilités de colères de mensonges et cette avalanche d'amours qui ne cesse de tarabuster aa"
calibrer la division à 40 caractères donneraient pour cette ligne :
contact(1) =3
contact(2) = "ce jour sans mesure cette infinité de possibilités"
contact(3) = " de colères de mensonges et cette avalanche"
contact(4) = " d'amours qui ne cesse de tarabuster aa"
il coupe le texte à l'espace donc il y a 40 caractères + ? jusqu'à la coupure (dans ma fonction le réglage est à 224)

Or si tu appliques cette phrase à ma fonction on obtient :
contact(1) =3
contact(2) = "ce jour sans mesure cette infinité de possibilités"
contact(3) = " de colères de mensonges et cette avalanche d'amours qui ne cesse de tarabuster aa"
contact(4) = " d'amours qui ne cesse de tarabuster aa"

Le contact(3) contient le contenu du contact(4), mais pourquoi ?
Là est mon problème.

j'espère avoir été plus clair

merci pour votre aide

**chrisaccess** · 30/03/2017, 21h56

effectivement j'ai oublié de préciser mes variables :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Option Explicit
 
Dim texte As String
Dim texte1 As String
Dim texte2 As String
Dim inter1 As String
 
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim fin As Long
 
Dim liste As Variant
Dim MyData As New DataObject
 
Dim CONT As String

**chrisaccess** · 31/03/2017, 00h14

Envoyé par unparia

2) une fonction doit retourner une valeur et donc être typée. Tu n'as pas typée la tienne.

Je n'ai pas analysé ton code (je ne pense pas être là pour corriger).

Bonsoir pour répondre à tes remarques :

Une fonction doit être typée : je les types rarement car elle m'ont posés plus de problèmes dans leur utilisation que de solutions.
Sur ce lien il précise que typé une fonction n'est pas obligatoire : http://silkyroad.developpez.com/vba/fonctions/

Pour l'analyse de mon code, c'est dommage que tu n'est pas pris le temps de me faire progresser sur mes erreurs car je ne la trouve pas.

Mais merci pour ton code qui m'a donné l'outil pour avoir une fonction correcte.
Ci dessous ta proposition adaptée à mon code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
Option Explicit
 
Dim texte As String
Dim texte1 As String
Dim texte2 As String
Dim inter1 As String
 
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim fin As Long
 
Dim CONT As String
 
Dim liste As Variant
Dim MyData As New DataObject
 
Sub contactosr(interloc As String, contenu As String)
 
a = Len(contenu) 'compte le nombre de caractère du contact - max 250
 
If a > 249 Then
 
    liste = contacts(contenu)
    b = UBound(liste)
    For c = 0 To b
        d = c + 1
        inter1 = interloc & " " & d & "/" & b + 1 ' interlocuteur et ajouter numero / nombre de contacts
        MyData.SetText inter1
        MyData.PutInClipboard
        Load contact
            contact.Image3.Visible = True
            contact.Label1.Visible = True
            contact.Label5.Caption = inter1
        contact.Show vbModal
 
        Unload contact
 
        MyData.SetText liste(c)
        MyData.PutInClipboard
 
        Load contact
            contact.Image2.Visible = True
            contact.Label2.Visible = True
            contact.Label5.Caption = liste(c)
        contact.Show vbModal
 
 
        Unload contact
    Next c
 
Else
 
    MyData.SetText interloc
    MyData.PutInClipboard
    Load contact
        contact.Image3.Visible = True
        contact.Label1.Visible = True
        contact.Label5.Caption = interloc
    contact.Show vbModal
 
    Unload contact
 
    MyData.SetText contenu
    MyData.PutInClipboard
    Load contact
        contact.Image2.Visible = True
        contact.Label2.Visible = True
        contact.Label5.Caption = contenu
    contact.Show vbModal
 
    Unload contact
 
End If
 
End Sub
 
Function contacts(contens As String) As Variant
 
    '************************* LIMITER A 10 CONTACTS ***************************************
       '------- procedure pour scinder la requete -------------
    'La chaine sera scindée si sa longueur est supérieure à 249 caractères
 
 
Dim TATA As String
Dim POS As Integer
Dim max As Integer
 
  TATA = contens
  max = 224
  POS = max
  Do While POS < Len(contens)
    If Mid(contens, POS, 1) = " " Then
      Mid(contens, POS, 1) = Chr(1)
    Else
      TATA = Left(contens, POS)
      POS = InStrRev(TATA, " ")
      Mid(contens, POS, 1) = Chr(1)
    End If
    POS = POS + max + 1
  Loop
  contacts = Split(contens, Chr(1))
 
End Function

Merci pour ton aide, je n'ai pas encore ce niveau et j'ai redécouvert des fonctions que je devrais utiliser plus souvent.

**Al__22** · 30/03/2017, 17h53

Sinon il est possible juste de faire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
debut = 1
ReDim requete((Len(contens) / 224))
Do While debut <> 0
    debut = InStr(224, contens, " ")
    texte = Left(contens, IIf(debut <> 0, debut, Len(contens)))
    requete(i) = texte: i = i + 1
    If Len(contens) > debut And debut <> 0 Then contens = Mid(contens, debut + 1)
Loop
 
For Each req In requete
    MsgBox req
Next

**Marc-L** · 30/03/2017, 18h45

Bonjour !

Dans le même genre, démonstration chargeant le texte depuis la cellule A1 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub Demo()
        Const L = 250
          Dim S$, T$(), P&, N&
              S = [A1].Value
        ReDim T(1 To Len(S) \ L - (Len(S) Mod L > 0))
    While Len(S) > L
           P = InStrRev(S, " ", L)
           N = N + 1
        T(N) = Left$(S, P)
           S = Mid$(S, P + 1)
    Wend
           N = N + 1
        T(N) = S
 
    For P = 1 To N
        Debug.Print "T(" & P & ") :"; Len(T(P)); vbLf; T(P); vbLf
    Next
End Sub

_________________________________________________________________________________________________________

Merci de cliquer sur

pour chaque message ayant aidé puis sur

pour clore cette discussion …

___________________________________________________________________________________________________________

Je suis Paris, London, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

**chrisaccess** · 30/03/2017, 22h14

Envoyé par Al__22

Sinon il est possible juste de faire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
debut = 1
ReDim requete((Len(contens) / 224))
Do While debut <> 0
    debut = InStr(224, contens, " ")
    texte = Left(contens, IIf(debut <> 0, debut, Len(contens)))
    requete(i) = texte: i = i + 1
    If Len(contens) > debut And debut <> 0 Then contens = Mid(contens, debut + 1)
Loop
 
For Each req In requete
    MsgBox req
Next