Autres Excel et le dessin de formes.

OlivGM

XLDnaute Occasionnel
Bonjour à tous,

Excel peut-il dessiner des formes (carré ou rectangle), en respectant les mm donnés en saisie, et quelles que soient la largeur des colonnes ou hauteur des lignes?
(si on modifie hauteur ou largeur, il réadapterait la taille du ou des dessins (jusqu'à 6 par feuille)

Merci de votre aide et bon am.

oliv'GM
 

Pièces jointes

  • Classeur1.xlsx
    10.4 KB · Affichages: 27

Nico_J

XLDnaute Junior
Bonjour,
essai ça, à adapter
VB:
Sub Ajoute_une_forme_automatique()
    Posh = Range("A2").Left
    Posv = Range("A2").Top
    LWidth = Range("A2").Width
    HHeight = Range("A2").Height
With Worksheets("Feuil1").Shapes.AddShape(msoShapeRectangle, Posh, Posv, LWidth, HHeight)
    .Name = "NomForme"
    .TextFrame.Characters.Text = "Le texte dans la forme"
End With
End Sub
 

Pièces jointes

  • Classeur1f.xlsm
    17.8 KB · Affichages: 7

Nico_J

XLDnaute Junior
En ce basant sur tes cellules colorées
Avoir si ça convient
VB:
Function PosSh(rng As Range)
Dim Posh As Double, Posv As Double, Wwidth As Double, Hheight As Double
Posh = rng.Left: Posv = rng.Top: LWidth = rng.Width: Hheight = rng.Height
    With Worksheets("Feuil1").Shapes.AddShape(msoShapeRectangle, Posh, Posv, LWidth, Hheight)
        .Name = "NomForme"
        .TextFrame.Characters.Text = "Le texte"
    End With
End Function

Sub Test()
Dim lig As Long, i As Long, j As Long
lig = 2
For i = lig To 6
    PosSh Range("A" & lig)
    PosSh Range("B" & lig)
lig = lig + 1
Next i
For j = 1 To 6: PosSh Range("F" & j): Next j
End Sub
 

Pièces jointes

  • Classeur1f.xlsm
    19.3 KB · Affichages: 4

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

Juste 2 minutes avant le couvre-feu
(faut bien s'occuper ;))
VB:
Sub DesFormesEtDesTeintesPourDétente()
Dim rng As Range, shp As Shape, i&, j&
Randomize 1600
For i = 1 To 3
    For j = 1 To 6
    Set rng = Cells(i, j)
    With rng
        Set shp = ActiveSheet.Shapes.AddShape(1, .Left, .Top, .Width, .Height)
        shp.Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
        shp.TextFrame2.TextRange.Text = "TEST"
        shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    End With
    Next j
Next i
End Sub
 

Modeste geedee

XLDnaute Barbatruc
Bonsour®
Bonjour à tous,

Excel peut-il dessiner des formes (carré ou rectangle), en respectant les mm donnés en saisie, et quelles que soient la largeur des colonnes ou hauteur des lignes?
(si on modifie hauteur ou largeur, il réadapterait la taille du ou des dessins (jusqu'à 6 par feuille)

Merci de votre aide et bon am.

oliv'GM
VB:
Sub position_Shape()
Dim rng As Range, shp As Shape, Ligne&, Colonne&
ActiveSheet.DrawingObjects.Select
Selection.Delete
For Ligne = 2 To 5 
    Set rng = Cells(Cells(Ligne, 3), Cells(Ligne, 4))
    With rng
        Set shp = ActiveSheet.Shapes.AddShape(1, _
                .Left, _
                .Top, _
                Application.CentimetersToPoints(Cells(Ligne, 1) / 10), _
                Application.CentimetersToPoints(Cells(Ligne, 2) / 10))                
        shp.TextFrame.Characters.Text = shp.TopLeftCell.Address
        shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vbRed
        shp.Fill.Visible = msoFalse
    End With
Next Ligne
End Sub
1609845452733.png
 

Pièces jointes

  • image cm to pt.xlsm
    23.7 KB · Affichages: 8

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

[Précisions]
J'aurai du préciser que ma macro n'était qu'une macro de test (à vocation illustrative)
J'ai cru que le nom de la macro le laissait aisément deviner ;)
D'autant qu'elle ne réponds pas au problème posé en message#1, ce que fait le code du message#7.
Mais comme le couvre-feu est encore loin, ce soir j'écris mon message plus posément et je prends de le temps de réfléchir
(enfin c'est que je crois ;))
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 885
Membres
101 830
dernier inscrit
sonia poulaert