Ajuster Texte dans une shape

[Seb]

Bonsoir le forum,

Je cherche désespérément à ajuster un texte dans une shapes. J'ai trouvé un moyen d'ajuster la shapes au texte mais je veux agir sur le texte, je veux pas que ma shapes se redimensionne.

Quelqu'un connaitrait la méthode ??

Merci beaucoup,
Seb

 

[Lone-wolf]

Bonsoir Seb

C'est simple comme tout, tu sélectionne le texte et tu met la grandeur que tu veux.

 

[Seb]

Bonsoir lone-wolf
Oui ca j'y arrive
L'idée c'est que je rentre du texte via pls USF qui est injecté dans diverse Shape. Il faut que tout les textes soient lisibles car les shapes sont de tailles différentes.
Et bien sûr il fait que ca soit rapide, je voudrais justement pas à avoir rentrer dans toutes les shapes pour modifier la police

 

[Lone-wolf]

Si tu mettais le fichier pour avoir une idée. Sinon un exemple à adapter

With ActiveSheet.Shapes("shape1")
         .TextFrame.Characters.Text = "Bonsoir"
       .TextFrame.Characters.Font.Size = 8
      .TextFrame.Characters.Font.Name = "Comic Sans Ms"
End With

 

[Seb]

Je joins un extrait de mon fichier (L'original à plus de 200 shapes/feuilles).
Je peux pas la formater car je ne peux pas savoir à l'avance la quantité de texte qui peut etre insérer, c'est pour ça que je voudrais un syntaxe qui me le ferais automatiquement.

 

[PMO2]

Bonjour,
L'idée est de tester la taille de la police du texte dans une Shape Rectangle temporaire pour en obtenir la bonne Size.
Essayez de remplacer le code Private Sub CommandButton1_Click() par ce qui suit (les ajouts sont cernés par des ###)

Private Sub CommandButton1_Click()
Dim iTop As Single, ileft As Single
Dim iCata As String
Dim iTexte(2) As String
Dim NomTG_Texte As String
Dim i As Long
Dim NbCar(2) As Long
NomTG_Texte = Application.Caller
iCata = "CATA_" & Mid(Application.Caller, 4)
iTexte(1) = Trim(TextBox1)
iTexte(2) = Trim(TextBox4)
NbCar(2) = Len(iTexte(2))
NbCar(1) = Len(iTexte(1))
If NbCar(2) > 0 Then
    ActiveSheet.Shapes(NomTG_Texte).TextFrame.Characters.Text = Trim(iTexte(1)) & vbCrLf & "[" & Trim(iTexte(2)) & "]"
    'ActiveSheet.Shapes(NomTG_Texte).TextFrame.AutoSize = True
Else
    ActiveSheet.Shapes(NomTG_Texte).TextFrame.Characters.Text = Trim(iTexte(1))
    ActiveSheet.Shapes(NomTG_Texte).TextFrame.Characters.Font.ColorIndex = 1
End If
If NbCar(2) > 0 Then
    ActiveSheet.Shapes(NomTG_Texte).TextFrame.Characters(Start:=1, Length:=NbCar(1)).Font.ColorIndex = 1
    ActiveSheet.Shapes(NomTG_Texte).TextFrame.Characters(Start:=NbCar(1) + 1, Length:=NbCar(2) + 10).Font.ColorIndex = 3
End If
If CheckBox1 = True Then
    iTop = ActiveSheet.Shapes(NomTG_Texte).Top
    ileft = ActiveSheet.Shapes(NomTG_Texte).Left
    ActiveSheet.Shapes(iCata).Visible = True
    ActiveSheet.Shapes(iCata).Top = iTop - 5
    ActiveSheet.Shapes(iCata).Left = ileft - 5
Else
    ActiveSheet.Shapes(iCata).Visible = False
End If
If CheckBox2 = True Then
    ActiveSheet.Shapes(Application.Caller).DrawingObject.Interior.ColorIndex = 15
Else
    ActiveSheet.Shapes(Application.Caller).DrawingObject.Interior.ColorIndex = 2
End If

'######### ajout pmo
Dim SH As Shape
Dim SH_pmo As Shape
Dim W As Double
Dim H As Double
'---
Set SH = ActiveSheet.Shapes(Application.Caller)
W = SH.Width
H = SH.Height
'--- Création d'un object Rectangle temporaire ---
Application.ScreenUpdating = False
Set SH_pmo = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, W, H)
SH_pmo.TextEffect.Text = SH.TextEffect.Text
SH_pmo.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
'--- Détermine la taille adéquate de la police ---
Do
  SH_pmo.TextEffect.FontSize = SH_pmo.TextEffect.FontSize - 1
  SH_pmo.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
Loop Until SH_pmo.Width <= W And SH_pmo.Height <= H
SH.TextEffect.FontSize = SH_pmo.TextEffect.FontSize
SH_pmo.Delete
Application.ScreenUpdating = True
'#########

Unload Me
End Sub

 

[Seb]

Bonjour PMO2,

Ton fichier marche impeccable, mais pour une raison inconnu sur mon fichier ça ne prend pas et je sais pas du tout pourquoi. L'écriture est la même pourtant.

 

[PMO2]

Certaines Shapes de votre classeur ne sont pas reliées à une macro alors que d'autres le sont avec des macros inexistantes.
Essayez le code suivant pour identifier les propriétés Name et OnAction de chaque Shape et corriger ce qui ne va pas.

Sub testShapes()
Dim S As Worksheet
Dim SH As Shape
Dim i&
'---
Set S = Sheets.Add(After:=Sheets(Sheets.Count))
For Each SH In Sheets("POS PENETRANTE").Shapes
  i& = i& + 1
  S.Cells(i&, 1) = SH.Name
  S.Cells(i&, 2) = SH.OnAction
Next SH
End Sub

 

[PMO2]

D'autre part, travaillez avec des variables Object (en l'occurrence Shape) comme dans ce qui suit.

'Private Sub UserForm_initialize()
'Dim iCata As String, i As Long
'Dim iTexte As String
'Dim NomTG_Texte As String
'Dim iT() As String
'TextBox3 = Application.Caller
'iCata = "CATA_" & Mid(Application.Caller, 4)
'iT() = Split(ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text, "[")
'If InStr(1, ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text, "[") > 0 Then
'    TextBox1 = Replace(Trim(iT(0)), Chr(10), "")
'    TextBox4 = Replace(Trim(iT(1)), Chr(10), "")
'    TextBox4 = Replace(Trim(iT(1)), "]", "")
'Else
'    TextBox1 = Replace(Trim(ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text), Chr(10), "")
'
'End If
'If ActiveSheet.Shapes(iCata).Visible = True Then
'    CheckBox1 = True
'Else
'    CheckBox1 = False
'End If
'If ActiveSheet.Shapes(Application.Caller).DrawingObject.Interior.ColorIndex = 15 Then
'    CheckBox2 = True
'Else
'    CheckBox2 = False
'End If
'End Sub
Private Sub UserForm_initialize()
Dim iCata As String, i As Long
Dim iTexte As String
Dim NomTG_Texte As String
Dim iT() As String
Dim SH As Shape
'---
Set SH = ActiveSheet.Shapes(Application.Caller)
TextBox3 = SH.Name
iCata = "CATA_" & Mid(SH.Name, 4)
iT() = Split(SH.TextFrame.Characters.Text, "[")
If InStr(1, SH.TextFrame.Characters.Text, "[") > 0 Then
    TextBox1 = Replace(Trim(iT(0)), Chr(10), "")
    TextBox4 = Replace(Trim(iT(1)), Chr(10), "")
    TextBox4 = Replace(Trim(iT(1)), "]", "")
Else
    TextBox1 = Replace(Trim(SH.TextFrame.Characters.Text), Chr(10), "")
End If
If ActiveSheet.Shapes(iCata).Visible = True Then
    CheckBox1 = True
Else
    CheckBox1 = False
End If
If SH.DrawingObject.Interior.ColorIndex = 15 Then
    CheckBox2 = True
Else
    CheckBox2 = False
End If
End Sub

 

[Seb]

Re Bonsoir,

En tout cas merci pour ton aide, suis loin d'être un pro en vba. Jai bien travaillé avec des variables objets, mais j'ai toujours pas une ecriture qui s'adapte a mon shapes.

 

[PMO2]

J'ai fait une variable publique pour la Shape concernée et une fonction qui détermine la bonne taille de la police. Essayez d'étendre le principe à tous vos UserForms.
Voir les modifications apportées (cernées par des "'"")

1) module Appel
Public mySH As Shape '""" modif pmo """
Sub Appel_POS()

2) UserForm POS
Private Sub UserForm_initialize()
Private Sub CommandButton1_Click()

3) module Module2
Sub test()
Function GoodFontSize(SH As Shape) As Single

 

[Seb]

Bonjour PMO2,

1000 merci pour le coup de main ! Je viens de tester c'est exactement ce que je cherchais. Je vais étudier le code pour le comprendre, j'ai encore du mal avec les fonctions.

Trés bonne fin de soirée !

Seb