[VBA 2000-2003] FitText dans un tableau

Bonjour

[ Cette réponse est faite sur le forum public Word :
news://msnews.microsoft.com/microsoft.public.fr.word ]

Je vais tenter d'être clair et précis, ce qui va forcément être un peu long.

Je suis en train de finaliser un document "un peu compliqué" (pour moi au moins) avec
pas mal de macros. Parmi ces macros, certaines construisent des tableaux dans le
document. Les macros fixent les dimensions du tableau ( hauteur des lignes et largeur
des cellules). Les cellules sont prévues pour recevoir du texte de taille assez
variable... Mais c'est prévu pour occuper une seule ligne. Cependant, Il arrive qu'avec
la police et la taille fixée au départ, un retour de ligne augmente la hauteur d'un
ligne ce qui met en l'air la mise en page... Je pourrais choisir un police plus petite
pour que cela ne se produise pas mais ces cas là sont rares et le reste du temps, la
police est "bien adaptée"...

Je pensais que la propriété FitText d'une cellule conviendrait mais lorsque le texte
est cours, il est étiré pour remplir la cellule en largeur et c'est particulièrement
moche.

Vous pouvez essayer le vieil astuce qui consiste à ajouter un caractère
de tabulation (VbTab) en fin de texte de chaque cellule.
En espérant que ça ne gêne pas autre chose.

--
A+

Bonsoir,

Geo wrote:
(...)

Vous pouvez essayer le vieil astuce qui consiste à ajouter un
caractère de tabulation (VbTab) en fin de texte de chaque cellule.
En espérant que ça ne gêne pas autre chose.

Merci de te pencher sur cette affaire.

Je viens de tester et si je ne m'abuse cela ne supprime pas
l'étirement d'un texte cours... (à moins peut-être de définir une
tabulation unique particulière sur le paragraphe associé ... je n'ai
pas testé ça...)

Quoi qu'il en soit cette "astuce" ne répond pas aux questions posées
en fin de message...

C'est tout de même bizarre que l'on ne puisse pas savoir via VBA
combien de lignes utilisent concrètement le contenu d'une cellule...

A+

Cordialement,

HB

Bonjour

[ Cette réponse est faite sur le forum public Word :
news://msnews.microsoft.com/microsoft.public.fr.word ]

Je viens de tester et si je ne m'abuse cela ne supprime pas l'étirement d'un texte
cours...

J'ai essayé à la main, ça a marché.
Il faudrait que je le fasse en vba, ce sera pour demain ....

C'est tout de même bizarre que l'on ne puisse pas savoir via VBA combien de lignes
utilisent concrètement le contenu d'une cellule...

Si sans doute, peut-être en utilisant la position du point d'insertion
(Application.informations) mais vu que la première solution avait l'air
de marcher, je n'ai pas cherché.

--
A+

Bonjour

[ Cette réponse est faite sur le forum public Word :
news://msnews.microsoft.com/microsoft.public.fr.word ]

Toujours pour le FitText, voici une macro qui ajoute le vbTab au bon
endroit, c'est probablement pour une raison d'emplacement que ça n'a
pas marché chez vous.

Sub Ajuster()
Dim Doc As Document
Dim MaTable As Table
Dim Cellule As Cell
Dim TexteO As String
Set Doc = ActiveDocument
Debug.Print Doc.name
'Premier tableau
Set MaTable = ActiveDocument.Tables(1)
For Each Cellule In MaTable.Range.Cells
TexteO = Cellule.Range.Text
'Troncature des caractères non imprimables à la fin du texte original
While Asc(Right(TexteO, 1)) < Asc("!")
TexteO = Left(TexteO, Len(TexteO) - 1)
Wend
Cellule.Range.Text = TexteO & vbTab
Cellule.FitText = True
Next
End Sub

La macro est écrite de manière à donner un résultat correct même si
vous la passez plusieurs fois.
Par contre le résultat n'est pas toujours bon si vous avec plusieurs
paragraphes dans la même cellule, les premiers sont ajustés comme cela
vous est arrivé. Ça peut évidemment être complété.

La fin de ligne est tronquée dans certains cas, mais à la main aussi,
je ne sais pas pourquoi.

--
A+

Re

La macro est écrite de manière à donner un résultat correct même si vous la passez
plusieurs fois.
Par contre le résultat n'est pas toujours bon si vous avec plusieurs paragraphes dans
la même cellule, les premiers sont ajustés comme cela vous est arrivé. Ça peut
évidemment être complété.

Ne marche pas non plus si la cellule est vide.

La fin de ligne est tronquée dans certains cas, mais à la main aussi, je ne sais pas
pourquoi.

Comme ça fait la même chose avec la bêta 2010, je l'ai signalé.
On verra bien.

--
A+

bonjour,

Geo wrote:

Sub Ajuster()
Dim Doc As Document
Dim MaTable As Table
Dim Cellule As Cell
Dim TexteO As String
Set Doc = ActiveDocument
Debug.Print Doc.name
'Premier tableau
Set MaTable = ActiveDocument.Tables(1)
For Each Cellule In MaTable.Range.Cells
TexteO = Cellule.Range.Text
'Troncature des caractères non imprimables à la fin du texte
original
While Asc(Right(TexteO, 1)) < Asc("!")
TexteO = Left(TexteO, Len(TexteO) - 1)
Wend
Cellule.Range.Text = TexteO & vbTab
Cellule.FitText = True
Next
End Sub

je vais tester ça mais en l'adaptant :

Normalement, il suffit que j'ajoute vbTab avec selection.Typetext
après avoir mis ce qui doit aller dans la cellule

Chaque cellule ne contient qu'un paragraphe (et ne doit faire qu'une
ligne)

En ajoutant VbTab au moment de l'écriture, je contrôlerais mieux cette
affaire.

Je me méfie des manipulations sur range.text car certaines cellules
utilisent des caractères spéciaux ajoutés avec
Selection.InsertSymbol Font:="Symbol", ... etc. ...
et asc() ne retourne alors rien d'utile ...

pour finir :
Un truc bizarre :

Si une cellule contient "concrètement" n caractères

len(oRange.text) vaut n+2
oRange.characters.count vaut n+1

avec
set oRange = Tablo.Cells(i,j).Range

au départ ça surprend un peu ;o)

HB

re,

je viens de tester
- en ajoutant VbTab à la fin
-> c'est la zone complète...

- en utilisant la procédure proposée
l'étirement a lieu ...

Je développe et teste avec office2000...
Sans doute est-ce là l'os ...


Les utilisateurs auront 2000 ou 2003
(... peut-être un ou deux office2007)
je préfère choisir une voie qui marche pour tous...


HB

Bonjour

[ Cette réponse est faite sur le forum public Word :
news://msnews.microsoft.com/microsoft.public.fr.word ]

Normalement, il suffit que j'ajoute vbTab avec selection.Typetext après avoir mis ce
qui doit aller dans la cellule

Chaque cellule ne contient qu'un paragraphe (et ne doit faire qu'une ligne)

En ajoutant VbTab au moment de l'écriture, je contrôlerais mieux cette affaire.

D'accord
[...]

Si une cellule contient "concrètement" n caractères

len(oRange.text) vaut n+2
oRange.characters.count vaut n+1
avec
set oRange = Tablo.Cells(i,j).Range

au départ ça surprend un peu ;o)

La fin de cellule est un caractère qui occupe deux octets !
On ne trouve ça nulle part dans la doc.
C'est pour cela que dans la macro, on élimine tous les octets dont la
valeur est inférieure à "!" qui est le premier caractère imprimable.

--
A+

Bonjour

[ Cette réponse est faite sur le forum public Word :
news://msnews.microsoft.com/microsoft.public.fr.word ]
re,

je viens de tester
- en ajoutant VbTab à la fin
-> c'est la zone complète...

- en utilisant la procédure proposée
l'étirement a lieu ...

Je développe et teste avec office2000...
Sans doute est-ce là l'os ...

Possible, essayez quand même en ajoutant à la main une tabulation
(CTL+Tab) pour en avoir la certitude

Les utilisateurs auront 2000 ou 2003
(... peut-être un ou deux office2007)
je préfère choisir une voie qui marche pour tous...

Ca tombe bien, je viens de terminer une petite macro qui travaille sur
la position du point d'insertion.
On tente d'abord de réduire l'espace entre les caractères, puis on
réduit la police progressivement jusqu'à 8 points.
La macro balaye le document actif et traite tous les tableaux.
Un message indique quand le traitement est terminé.
Sub Ajuster2()
Dim Doc As Document
Dim MaTable As Table
Dim Cellule As Cell
Dim TexteO As String
Dim i As Integer
Dim j As Integer
Dim PosMin As Long
Dim PosMax As Long
Dim Pos As Long
Set Doc = ActiveDocument
Debug.Print Doc.name
For i = 1 To Doc.Tables.Count ' Table
Set MaTable = ActiveDocument.Tables(i)
For j = 1 To MaTable.Rows.Count ' Ligne
'PosMin = 9999999
'PosMax = 0
For Each Cellule In MaTable.Rows(j).Range.Cells ' Cellule
Cellule.Select
PosMin = 9999999
PosMax = 0
Pos = Selection.Information(wdVerticalPositionRelativeToPage)
If Pos < PosMin Then PosMin = Pos
If Pos > PosMax Then PosMax = Pos
Selection.EndKey Unit:=wdLine
Pos = Selection.Information(wdVerticalPositionRelativeToPage)
If Pos < PosMin Then PosMin = Pos
If Pos > PosMax Then PosMax = Pos
While PosMax - PosMin > 1 And Cellule.Range.Font.Spacing > -0.5
' Plusieurs lignes
' condensation du texte progressivement jusqu'à 0.5
Cellule.Range.Font.Spacing = Cellule.Range.Font.Spacing - 0.1
Debug.Print Cellule.Range.Font.Spacing
PosMax =
Selection.Information(wdVerticalPositionRelativeToPage)
Wend
' Si ça ne suffit pas on réduit la taille des caractères jusqu'à
8
While PosMax - PosMin > 1 And Cellule.Range.Font.Size >= 8
Debug.Print " plusieurs lignes 2 ", Cellule.Range.Font.Size
Cellule.Range.Font.Size = Cellule.Range.Font.Size - 0.5
PosMax =
Selection.Information(wdVerticalPositionRelativeToPage)
Wend
Next Cellule
DoEvents
Next j ' Ligne suivante
DoEvents
Next i ' Tableau suivant
MsgBox "Terminé"
End Sub

A ne passer qu'en mode Page.
Espérons que ça marche pour toutes les versions.

--
A+

Bonsoir,

OUI !!! c'est ça l'idée que je cherchais.
la position verticale relative par rapport à la page permet de
détecter la présence de plusieurs lignes...

j'avoue, c'est la première fois que j'utilise "Information" ...
Je me souviendrais, désormais, de son existence !

Je viens de tester et c'est nickel !

Merci
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Donc pour un cellule
====================================================== Sub AJUSTE1(Cellule as cell)

Cellule.Select
PosMin = 9999999
PosMax = 0
Pos = Selection.Information(wdVerticalPositionRelativeToPage)
If Pos < PosMin Then PosMin = Pos
If Pos > PosMax Then PosMax = Pos
Selection.EndKey Unit:=wdLine
Pos = Selection.Information(wdVerticalPositionRelativeToPage)
If Pos < PosMin Then PosMin = Pos
If Pos > PosMax Then PosMax = Pos

While PosMax - PosMin > 1 And Cellule.Range.Font.Spacing > -0.5
Cellule.Range.Font.Spacing = Cellule.Range.Font.Spacing - 0.1
PosMax =
Selection.Information(wdVerticalPositionRelativeToPage)
Wend

While PosMax - PosMin > 1 And Cellule.Range.Font.Size >= 8
Cellule.Range.Font.Size = Cellule.Range.Font.Size - 0.5
PosMax =
Selection.Information(wdVerticalPositionRelativeToPage)
Wend

End Sub
======================================================
qui pourrait devenir :
====================================================== Sub AJUSTE2(Cellule as cell)

Cellule.Select
PosMin = 9999999
PosMax = 0
Pos = Selection.Information(wdVerticalPositionRelativeToPage)
If Pos < PosMin Then PosMin = Pos
If Pos > PosMax Then PosMax = Pos

Selection.EndKey Unit:=wdLine
Pos = Selection.Information(wdVerticalPositionRelativeToPage)
If Pos < PosMin Then PosMin = Pos
If Pos > PosMax Then PosMax = Pos

If PosMax - PosMin > 1 then
Cellule.FitText=True
End If

End Sub
====================================================== Mais ajuste1 est plus raffiné ...
et visuellement c'est plutôt réussi...


Une question cependant :

Même en points, la position doit être identique sur une même "ligne
réelle" non ?

Chaque cellule contient une seule ligne parfois trop longue ... d'où
ce fil ;o)
Normalement, une cellule ne pourra donc pas être "à cheval" sur deux
pages...
La fin du contenu d'une cellule est forcément sur la même page et
après le début.

J'aurais donc tendance à simplifier en
============Ajuste2bis============= Cellule.Select
PosDebut = Selection.Information(wdVerticalPositionRelativeToPage)
Selection.EndKey Unit:=wdLine
PosFin = Selection.Information(wdVerticalPositionRelativeToPage)
If PosFin > PosDebut then
Cellule.FitText=True
end if
================================
Quel est le problème que je n'envisage pas ?

HB