Autochallenge programmation interfaces VBA

Version imprimable

Bonjour a tous
pour un autre sujet Unparia m'a donné une astuce pour gérer le fontweight ou même le fontWidth

j'ai plus ou moins repris l'astuce pour en faire autre chose :un compteur de ligne

en effet c'est un sujet qui est apparu très souvent: comment détecter les sauts de lignes dans une cellules quand il n'y en a pas!!!

mais que la propriété (format cellule/ajuster a la ligne) est activée et donc le texte visuellement sur plusieurs lignes

j'ai donc créé une petite fonction que je viens vous montrer

elle a lair de fonctionner correctement au vues des tests que j'ai fait

cependant je me pose une question au sujet de ce + 9 que l'on trouve dans la fonction on peut aller jusqu'à +7
a quoi est il du ?au fait que le texte dans les cellules a une marge gauche tandis que le label en autosize non ?
ma 2d question c'est aurait il un moyen de simplifier le code bien qu'étant pas très volumineux c'est peu de le dire
voila la fonction
Code:

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 Function ligne(cel) If cel.Text <> "" Then Set Obj = ActiveSheet.OLEObjects.Add("Forms.Label.1") With Obj: .Object.Font.Size = cel.Font.Size: e = 1 Do DoEvents i = i + 1 .Object.AutoSize = False .Width = 1000: .Object.Caption = Mid(cel.Text, 1, i): .Object.AutoSize = True: a = a + Mid(cel.Text, i, 1) If .Width > (cel.Width - 9) * e Then a = a & vbCrLf: e = e + 1 Loop Until i = Len(cel.Text) .Delete End With ligne = a End If End Function
et la sub de test

Code:

1 2 3 4 5 6 7 Sub test() Dim texte As String, cel As Range Set cel = ActiveSheet.[b2] texte = cel.Text ar = ligne(cel) MsgBox ar End Sub

si vous avez une autre voie a proposer je prends aussi bien entendu
merci pour vos retours et participation d'avance

Bonjour Patrick.

Une facon KISS.

Code:

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
 Sub TestRetourALaLigne()
  Set c = Cells(2, 2)
 
  c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"
  c.WrapText = True
 
  MsgBox CalculerNbrLignes(c)
 
 End Sub
 Function CalculerNbrLignes(c)
 
  Set cel2 = Worksheets("Feuil2").Cells(1, 1)
 
  cel2.Parent.Rows("1").Clear
  cel2.ColumnWidth = c.ColumnWidth
 
  c.Copy cel2
 
  cel2.WrapText = c.WrapText
  h = cel2.RowHeight
 
  cel2.WrapText = False
 
  CalculerNbrLignes = h / cel2.RowHeight
 
 End Function

Bonjour Docmarti
j'y avais pensé au rowheight en effet mais attention au formatage de la cellule si sa dimension avais été modifiée avant donc au pire utiliser la cells(rows.count,columns.count) pour le rapport
il y a moins de risque qu'elle ne soit pas d origine
cela dit ma question a été mal formulée j'en suis seul responsable

non seulement je veut le nombre de lignes mais je veux aussi le contenu ligne par ligne

je garde quand même ta façon KISS

a ma façon kissou
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 SSub TestRetourALaLigne() Set c = Cells(2, 2) c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo" c.WrapText = True MsgBox CalculerNbrLignes(c) End Sub Function CalculerNbrLignes(c) Set cel2 = c.Parent.Cells(Rows.Count, Columns.Count) cel2.Clear cel2.ColumnWidth = c.ColumnWidth h = cel2.RowHeight cel2.Value = c.Value cel2.WrapText = c.WrapText CalculerNbrLignes = cel2.RowHeight / h cel2.Clear End Function
par contre pour l'obtention de la valeur de chaque ligne c'est walouh le calcule donnerait faux
mais ca me donne une autre idée

re
@docmarti je suis parti de ta version kiss
mais je n'arrive pas a mettre au point le passage des saut de ligne reel et chose étonnante avec le même width le texte d'une ligne peut être plus long

Code:

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
Sub TestRetourALaLigne()
    Set c = Cells(2, 2)
    c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"
    c.WrapText = True
    MsgBox UBound(CalculerNbrLignes(c))
End Sub
Function CalculerNbrLignes(c) As Variant
    ReDim tablo(30)
    tabl = Split(c.Value, " ")
    Set cel2 = Cells(4, 2)    ' 'c.Parent.Cells(Rows.Count, Columns.Count)
    cel2.Clear
    cel2.ColumnWidth = c.ColumnWidth
    cel2.WrapText = c.WrapText:
    h = cel2.RowHeight
    a = 0
    For i = 0 To UBound(tabl)
        If InStr(tabl(i), vbLf) > 0 Then tabl(i) = Replace(tabl(i), vbLf, ""): saut = True
        cel2.Value = cel2.Value & tabl(i) & " "
        If cel2.RowHeight = h Then
            tablo(a) = tablo(a) & tabl(i) & " "
        Else
            a = a + 1: tablo(a) = tabl(i) & " "
            h = cel2.RowHeight
        End If
        If saut = True Then a = a + 1: saut = False
    Next
ReDim Preserve tablo(0 To a)
    cel2.Clear
    cel2.Resize(UBound(tablo), 1) = Application.Transpose(tablo)
    CalculerNbrLignes = tablo
End Function

02/06/2017, 12h14
Docmarti

Attention. Le texte suivant

Code:

c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"

contient un retour de ligne.
Il ne faut pas le supprimer car il fait partie du texte original.
02/06/2017, 12h19
patricktoulon

re
@Nicolas
bien venu dans mon nouveau motif de tourment cérébral :ptdr:
alors le but est de :
1. connaitre le nombre de ligne
2. connaitre la valeur de chaque ligne
une cellule ajustée a la ligne automatiquement par le menu (format cellule --->ajuster a la ligne automatiquement)affiche le texte sur plusieurs ligne ( c'est ce que l'on appelle le (wraptext)
tu constatera que si tu fait une recherche de saut de ligne par chr(10),chr(13),vbcrlf,vblf) tu n'en trouvera pas pourtant il y a bien plusieur lignes visuellement

donc le but avec le label en autosize c'est de l'alimenter jusqu'à quel théoriquement il atteigne la largeur de la cellule parti de la on a une ligne et on continue jusqu' au len(du texte)en mettant un repère a chaque fois que la (limite width * ligne déjà passée) est atteinte
ca fonctionne a peu près correctement

docmarti a apporter une idée en mémorisant le row height de départ et en le comparant au rowheight de l'arrivée en effet le compte est bon
seulement je voudrais avoir la valeur de chaque lignes

j'ai donc mijoté le code dans le post précédant mais c'est pas tout a fait au point
c'est une question que j'ai trouvé de nombreuses fois dans ce même forum et même ailleurs mais aucune vrai solution n'a pu être apporté a ce jour du moins je ne l'ai pas trouvé
alors haut les cœurs
02/06/2017, 12h23
patricktoulon

Citation:

Envoyé par Docmarti

Attention. Le texte suivant

Code:

c.Value = "C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"

contient un retour de ligne.
Il ne faut pas le supprimer car il fait partie du texte original.

oui docmarti la variable "saut" sert a traiter ce paramètre c'est justement la gestion de ce détail qui est le premier couic !
je pense pas le gérer correctement dans mon model
le 2d detail troublant c'est que un texte dans la cellule ajuster peut prendre une ligne et dans le résultat 2 avec le même columnwidth

Patrick, a partir de ton code.

KISS

Code:

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
Sub TestRetourALaLigne2()
    Set c = Cells(2, 2)
    c.Value = "                       C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo"
    c.WrapText = True
    MsgBox UBound(CalculerNbrLignes(c)) + 1
End Sub
Function CalculerNbrLignes(c) As Variant
 
    ReDim tablo(0)
    Set cel2 = Cells(4, 2)
    cel2.Clear
    cel2.ColumnWidth = c.ColumnWidth
    cel2.WrapText = c.WrapText:
     a = 0
    strTxt = Replace(c.Value, vbCrLf, vbLf)
 
    tablVbLf = Split(strTxt, vbLf)
 
    For j = 0 To UBound(tablVbLf)
 
    tabl = Split(tablVbLf(j), " ")
 
    h = cel2.RowHeight
 
    For i = 0 To UBound(tabl)
 
        cel2.Value = cel2.Value & tabl(i) & " "
        If cel2.RowHeight = h Then
            tablo(a) = tablo(a) & tabl(i) & " "
        Else
          a = a + 1:
         ReDim Preserve tablo(a)
            tablo(a) = tabl(i) & " "
            h = cel2.RowHeight
        End If
 
    Next
 
    If j < UBound(tablVbLf) Then
 
      a = a + 1
      ReDim Preserve tablo(a)
      cel2.Value = cel2.Value & vbLf
    End If
 
    Next
 
    Offset = 1
    Columns("C").Clear
    For i = 0 To UBound(tablo)
     cel2.Offset(Offset, 1).Select
     cel2.Offset(Offset, 1) = tablo(i)
     Offset = Offset + 1
    Next
 
    CalculerNbrLignes = tablo
 
End Function

je m'incline j'ai testé dans tout les sens ca match perfect !!!
en même temps j'était vraiment pas loin
peut être que dans le replace initial on pourrait replacer toute les forme de saut de ligne chr(10),chr(13),vbcrlf,vbclf, etc.....

compris:
boucle sur le split par saut de ligne
sous boucle par les espaces
incrementation de a si width ou augmentation de j

dommage un challenge qui n'aura pas duré longtemps

je vais chercher quelque chose de plus compliqué :ptdr:
version finale :
Code:

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 Sub TestRetourALaLigne2() Set c = Cells(2, 2) c.Value = " C'est une triste chose de penser que la nature parle et que le genre humain n'écoute pas." & vbLf & "Victor Hugo" c.WrapText = True MsgBox UBound(CalculerNbrLignes(c)) + 1 End Sub Function CalculerNbrLignes(c) As Variant ReDim tablo(0) Set cel2 = Cells(4, 2) cel2.Clear cel2.ColumnWidth = c.ColumnWidth cel2.WrapText = c.WrapText: a = 0 strTxt = Replace(c.Value, vbCrLf, vbLf) tablVbLf = Split(strTxt, vbLf) For j = 0 To UBound(tablVbLf) tabl = Split(tablVbLf(j), " ") h = cel2.RowHeight For i = 0 To UBound(tabl) cel2.Value = cel2.Value & tabl(i) & " " If cel2.RowHeight = h Then tablo(a) = tablo(a) & tabl(i) & " " Else a = a + 1: ReDim Preserve tablo(a) tablo(a) = tabl(i) & " " h = cel2.RowHeight End If Next If j < UBound(tablVbLf) Then a = a + 1 ReDim Preserve tablo(a) cel2.Value = cel2.Value & vbLf End If Next cel2.Resize(UBound(tablo) + 1, 1) = Application.Transpose(tablo) CalculerNbrLignes = tablo MsgBox Join(tablo, vbCrLf) End Function
docmarti:ccool::plusser:
je sais pas si tu t'en rends compte mais tu trouvera aucune version nulpart plus ou moins abracadabranthesque qui fonctionne correctement et tu peut remonter en arrière de quelque années en plus et dieux sais qu'il y a des exemples en masse
Bravo

EDIT:
oulah!!! attention les espace devant la chaine n'est pas anodine si je l'enleve de la chaine de depart ca ne vas pas du tout
peut etre va t il falloir fair un ajout avant traitement
du genre
app.rept(" ",cel.width/cel.font.size)

02/06/2017, 14h10
mercatog

Essaies ceci

Citation:

"Anticonstitutionnellement est un mot très long à écrire :hap: Voilà"
02/06/2017, 14h22
patricktoulon

re

Bonjour Mercatog
oui je viens de faire le test sans les espaces deveant et ca change tout
donc on continu
je pense que je me suis fourvoyé en voulant coller au plus proche en faisant par mot et pour coller au comportement de la cellule

je vais donc modifier mon model avec le label
en bouclant sur les mot et sous boucler sur les caractères
si tout les caractères du mot rentre OK sinon passe a la ligne

puisque boucle sur les mots ca match pas a 100%
boucle sur les caractères ca match pas a 100%
mixer les deux pour coller au plus proche du comportement du wraptext
exemple
une cellule de 110 pixels de width

avec
mercatog pat = 1 ligne

avec
mercatog Patrick = 2 lignes
donc
mercatog
Patrick
le "pat" est décalé en ligne suivante
c'est pour ca que par les caractères c'est pas possible par les mots non plus visiblement
donc il me faut les deux
du moins logiquement par rapport au comportement du wraptext
il faut que je teste le comportement avec un seul mot tres long comme tu dis ca doit différer un peut je pense
02/06/2017, 15h06
patricktoulon

re

je pense avoir trouver un autre moyen
avec 2 autre cellules en autofit
l'une pour tester la largeur du mot complet l'autre pour tester la largeur de ce qui a déjà été pris en compte plus le mot

la première si le mot dépasse la largeur de la cellule original on le coupe donc incrémentation de ligne et alimentation tablo

la 2 d si bon ajoute sinon incrémentation de ligne et alimentation

je dois partir en inter je reviens ce soir pour étudier cela
bon aprem
a+

Bon voila j'ai un résultat mais ce qui me gène c'est la calcul qui semble pas donner un résultat exact a chaque fois selon la dimension de la cellules
maintenant ca gere la phrase ou le mot si il est trop long

Code:

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
[Sub TestRetourALaLigne()
    Set c = Cells(2, 2)
    c.Value = "C'est une triste chose de penser que la nature anticonstitutionellement parle et que le genre humain n'écoute pas." & vbCrLf & "Victor Hugo"
    c.WrapText = True
End Sub
Sub testx()
    Dim Cel2, Cel3, I, M, Z, TEXTE, H, mot, mots
    Set cel1 = [b2]
    Set Cel2 = [c1]: Cel2.WrapText = True: Cel2.ColumnWidth = cel1.ColumnWidth: Cel2.ClearContents: H = Cel2.RowHeight
    Set Cel3 = [d2]: ActiveSheet.Columns("D").AutoFit
    phrase = Split(cel1.Value, vbCrLf)
    Z = -1
    Do
        Z = Z + 1
        mots = Split(phrase(Z), " ")
        M = -1
        Do
            M = M + 1
            Cel3.Value = mots(M)
            ActiveSheet.Columns(Cel3.Column).AutoFit
            If Cel3.ColumnWidth > cel1.ColumnWidth Then
                TEXTE = TEXTE & vbCrLf
                nbl = Cel3.ColumnWidth / (Cel3.ColumnWidth / cel1.ColumnWidth)
                For I = 1 To Len(mots(M)) Step nbl + 3: mot = mot & Mid(mots(M), I, nbl + 3) & " ": Next
                TEXTE = TEXTE & Replace(Trim(mot), " ", vbCrLf) & " "
                Cel2.Value = Cel2.Value & mots(M) & " "
                H = Cel2.RowHeight
            Else
                Cel2.Value = Cel2.Value & mots(M) & " "
                TEXTE = TEXTE & mots(M) & " "
                If Cel2.RowHeight > H Then TEXTE = Replace(TEXTE, mots(M), vbCrLf & mots(M)): H = Cel2.RowHeight
            End If
        Loop Until M = UBound(mots)
        Cel2.Value = Cel2.Value & vbCrLf
    Loop Until Z = UBound(phrase)
    MsgBox TEXTE
End Sub

06/06/2017, 17h50
Docmarti

J'ai bien l'impression que c'est possible uniquement si la cellule d'origine utilise une police a chasse non proportionnelle et qu'on lui applique en plus EntireColumn.AutoFit.
06/06/2017, 17h56
patricktoulon

re

Bonjour docmarti

tu l'aura compris dans cet exemple on traite non seulement les phrase (plusieurs mot sur la même ligne) mais aussi les mots qui seraient éventuellement trop longs

je sais ce que tu veux dire par police en chasse mais la version que j'ai déposé fonctionne mais c'est le + 3 qui me gène

j'aurais préféré un calcul avec les données des démentions directement

j'ai essayé de travailler en pixel et le résultat est plus probant visiblement

quest ce que ca donne ca chez toi

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Sub testZ()
ppx = (ActiveWindow.ActivePane.PointsToScreenPixelsX(3) - ActiveWindow.ActivePane.PointsToScreenPixelsX(0) / 3)
     Set Cel2 = [c1]: Cel2.WrapText = True: H = Cel2.RowHeight
    Cel2.Value = "anticonstitutionellement"
   Set Cel3 = [d1]:
   Cel3.Value = Cel2.Value
  ActiveSheet.Columns("D").AutoFit: Cel3.Font.Size = Cel2.Font.Size
  sizec1 = Cel2.Width * ppx
sizec2 = Cel3.Width * ppx
coeff = (sizec2 / sizec1)
MsgBox Mid(Cel2, 1, (Len(Cel2) / coeff))
End Sub

j'ai plutôt l'impression qu'il y a un margin left et right a respecter dans le calcul

06/06/2017, 19h01
Docmarti

Chez moi, ca donne le bon resultat mais pas toujours.
Exemple si b2.columnwidth et c1.columnwidth est egal a 8, ca ne donne plus le bon resultat.
06/06/2017, 19h21
patricktoulon

re
oui je sais
je me demande bien quelle règle est appliqué avec ce wraptext
1. nous savons qu'il y a un margin left on le voit bien
2. nous savons aussi qu'un mot trop long est coupé mais étonnamment il n'y a plus ce margin left
3. nous savons qu'il ne coupe pas un mot mais qu'il le met a la ligne si celui ci ajouté au texte existant dépasse la largeur
4. nous savons aussi que ces 3 précédents détails sont traités différemment selon la taille de la cellules
purée on passe a coté de quelque chose la mais quoi?