Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel À la recherche d'un vrai carré !

À la recherche d'un vrai carré !

16 réponses
Avatar
garnote
Bonjour tout le monde,

Voici une macro qui me permet de faire une construction
animée d'un carré «parfait». J'ai deux questions :
1. Me suis-je encore une fois inutilement compliqué la vie ?
Si oui, comment feriez-vous pour obtenir le même résultat ?
2. Comment faire pour réussir à colorier les deux diagonales
en rouge ?

Encore et encore : Vive le MPFE et vive Excelabo !

Serge
«Je m'excuse d'avoir fait les mathématiques aussi compliquées».

Dieu


Sub ConstructionAniméeCarréParfait()

'Sélectionnez une cellule et lancez cette macro.
ActiveWindow.DisplayGridlines = False
dx = ActiveCell.Left
dy = ActiveCell.Top + ActiveCell.Height
L = InputBox("Un nombre entier de pixels.", _
"Longeur du côté du carré que vous voulez obtenir")

'Ligne de haut en bas :
Set LHB = ActiveSheet.Shapes.AddLine(dx, dy, dx, dy)
With LHB
For i = 1 To L
.Height = i
DoEvents
Next i
End With

'Ligne de gauche à droite :
Set LGD = ActiveSheet.Shapes. _
AddLine(dx, dy + L, dx, dy + L)
With LGD
For i = 1 To L
.Width = i
.Left = dx + i - .Width
DoEvents
Next i
End With

'Ligne de bas en haut :
Set LBH = ActiveSheet.Shapes. _
AddLine(dx + L, dy + L, dx + L, dy + L)
With LBH
For i = 1 To L
.Height = i
.Top = dy + L - .Height
DoEvents
Next i
End With

'Ligne de droite à gauche :
Set LDG = ActiveSheet.Shapes. _
AddLine(dx + L, dy, dx + L, dy)
With LDG
For i = 1 To L
.Width = i
.Left = dx + L - i
DoEvents
Next i
End With

'Les deux diagonales :
Set diag1 = ActiveSheet.Shapes. _
AddLine(dx, dy, dx + L, dy + L)
Set diag2 = ActiveSheet.Shapes. _
AddLine(dx, dy + L, dx + L, dy)

'Tentative avortée pour colorier les diagonales en rouge :
'diag1.ShapeRange.Line.ForeColor.SchemeColor = 10
'diag2.ShapeRange.Line.ForeColor.SchemeColor = 10
End Sub
Signaler un problème avec ce contenu

6 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2
Avatar
isabelle
mais je la trouve super ta tortue et en plus il y a les hyppo. et pas
d'effet "flash" à l'écran. mais pour un vrai carré ;-) (et s'il n'y a
que cette forme sur la feuille )il faut lui ajouter
ActiveSheet.DrawingObjects.ShapeRange.Group

isabelle


Et moi alors, tu n'aimes pas ma tortue !

;-)))

Serge

"isabelle" a écrit dans le message de news:

est tu d'accord AV ?


Avec toi ? --> Toujours ! ;-)


:-)))))))))), ouff !!!

Au fait ? De quoi s'agit-il ? ;-))


c'est pour enlever l'effet "flash" de la disparition et réaparition du
quadrilataire à chaque redimantion du carré.

isabelle






Avatar
michdenis
Bonjour Garnote,

Voici comment mettre tes diagonales en couleur. Tu n'as qu'à remplacer ton code dans ta procédure par celui-ci.


'-----------------------------
'Les deux diagonales :
Dim Diag As Object
With ActiveSheet
Set Diag = .Shapes. _
AddLine(dx, dy, dx + L, dy + L).OLEFormat.Object
With Diag
.ShapeRange.Line.ForeColor.SchemeColor = 14
End With

Set Diag = .Shapes. _
AddLine(dx, dy + L, dx + L, dy).OLEFormat.Object
With Diag
.ShapeRange.Line.ForeColor.SchemeColor = 14
End With
End With
'-----------------------------


Salutations!




"garnote" a écrit dans le message de news:tFbnb.13142$
Bonjour tout le monde,

Voici une macro qui me permet de faire une construction
animée d'un carré «parfait». J'ai deux questions :
1. Me suis-je encore une fois inutilement compliqué la vie ?
Si oui, comment feriez-vous pour obtenir le même résultat ?
2. Comment faire pour réussir à colorier les deux diagonales
en rouge ?

Encore et encore : Vive le MPFE et vive Excelabo !

Serge
«Je m'excuse d'avoir fait les mathématiques aussi compliquées».

Dieu


Sub ConstructionAniméeCarréParfait()

'Sélectionnez une cellule et lancez cette macro.
ActiveWindow.DisplayGridlines = False
dx = ActiveCell.Left
dy = ActiveCell.Top + ActiveCell.Height
L = InputBox("Un nombre entier de pixels.", _
"Longeur du côté du carré que vous voulez obtenir")

'Ligne de haut en bas :
Set LHB = ActiveSheet.Shapes.AddLine(dx, dy, dx, dy)
With LHB
For i = 1 To L
.Height = i
DoEvents
Next i
End With

'Ligne de gauche à droite :
Set LGD = ActiveSheet.Shapes. _
AddLine(dx, dy + L, dx, dy + L)
With LGD
For i = 1 To L
.Width = i
.Left = dx + i - .Width
DoEvents
Next i
End With

'Ligne de bas en haut :
Set LBH = ActiveSheet.Shapes. _
AddLine(dx + L, dy + L, dx + L, dy + L)
With LBH
For i = 1 To L
.Height = i
.Top = dy + L - .Height
DoEvents
Next i
End With

'Ligne de droite à gauche :
Set LDG = ActiveSheet.Shapes. _
AddLine(dx + L, dy, dx + L, dy)
With LDG
For i = 1 To L
.Width = i
.Left = dx + L - i
DoEvents
Next i
End With

'Les deux diagonales :
Set diag1 = ActiveSheet.Shapes. _
AddLine(dx, dy, dx + L, dy + L)
Set diag2 = ActiveSheet.Shapes. _
AddLine(dx, dy + L, dx + L, dy)

'Tentative avortée pour colorier les diagonales en rouge :
'diag1.ShapeRange.Line.ForeColor.SchemeColor = 10
'diag2.ShapeRange.Line.ForeColor.SchemeColor = 10
End Sub
Avatar
Herdet
Bonsoir Serge,
Si c'est juste pour faire un carré sans effet visuel, voici une autre
solution plus rapide avec une shape.
Quand à modifier la couleur des diagonales, il faut ^tres raisonnable avec
ce qui n'est au fond qu'un tableur et loin d^tre un logiciel de dessin mais
est-ce bien nécessaire ce changement de couleur ?
Amicalement
Robert

Sub Carré_shape()
'Sélectionnez une cellule et lancez cette macro.
ActiveWindow.DisplayGridlines = False
dx = ActiveCell.Left
dy = ActiveCell.Top + ActiveCell.Height
L = InputBox("Un nombre entier de pixels.", "Longeur du côté du carré
que vous voulez obtenir")
ActiveSheet.Shapes.AddShape(msoShapeBevel, dx, dy, L, L).Select
With Selection
.ShapeRange.Adjustments.Item(1) = 0.5 ' forme en pyramide
.ShapeRange.Fill.Visible = msoTrue
.ShapeRange.Fill.Solid
.ShapeRange.Fill.ForeColor.SchemeColor = 65
.ShapeRange.Fill.Transparency = 1# ' visibilité ou non des 2
pans à l'ombre
.ShapeRange.Line.Weight = 0.75
.ShapeRange.Line.DashStyle = msoLineSolid
.ShapeRange.Line.Style = msoLineSingle
.ShapeRange.Line.Transparency = 0#
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.ForeColor.SchemeColor = 64
.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Rotation = 0#
.Placement = xlMove
.PrintObject = True
End With
End Sub
Avatar
gee-dee-
;-)))
tout a fait serge, il n'y a pas lieu de selectionner la forme,
puisque le fait de faire Set diag identifie parfaitement l'objet
dont on colorie alors la ligne propiété "line"

'Les deux diagonales :
Set diag1 = ActiveSheet.Shapes.AddLine(dx, dy, dx + L, dy + L)
Set diag2 = ActiveSheet.Shapes.AddLine(dx, dy + L, dx + L, dy)
diag1.Line.ForeColor.SchemeColor = 10
diag2.Line.ForeColor.SchemeColor = 10

simplement !!!!
Avatar
garnote
Yep !
J'avais un ShapeRange superfétatoire ;-)

Serge

"gee-dee-" a écrit dans le message de news:

;-)))
tout a fait serge, il n'y a pas lieu de selectionner la forme,
puisque le fait de faire Set diag identifie parfaitement l'objet
dont on colorie alors la ligne propiété "line"

'Les deux diagonales :
Set diag1 = ActiveSheet.Shapes.AddLine(dx, dy, dx + L, dy + L)
Set diag2 = ActiveSheet.Shapes.AddLine(dx, dy + L, dx + L, dy)
diag1.Line.ForeColor.SchemeColor = 10
diag2.Line.ForeColor.SchemeColor = 10

simplement !!!!




Avatar
garnote
Merci chers collègues et chère collègue pour vos suggestions.
Tout baigne dans l'huile et allez hop! un tite bouteille de Grolsch !
Tout ça est nettement plus amusant que de
corriger mes maudits examens !
Et pour faire rougir mes diagonales,
c'est Geedee le grand cheuf !

Serge


"garnote" a écrit dans le message de news:
tFbnb.13142$
Bonjour tout le monde,

Voici une macro qui me permet de faire une construction
animée d'un carré «parfait». J'ai deux questions :
1. Me suis-je encore une fois inutilement compliqué la vie ?
Si oui, comment feriez-vous pour obtenir le même résultat ?
2. Comment faire pour réussir à colorier les deux diagonales
en rouge ?

Encore et encore : Vive le MPFE et vive Excelabo !

Serge
«Je m'excuse d'avoir fait les mathématiques aussi compliquées».

Dieu


Sub ConstructionAniméeCarréParfait()

'Sélectionnez une cellule et lancez cette macro.
ActiveWindow.DisplayGridlines = False
dx = ActiveCell.Left
dy = ActiveCell.Top + ActiveCell.Height
L = InputBox("Un nombre entier de pixels.", _
"Longeur du côté du carré que vous voulez obtenir")

'Ligne de haut en bas :
Set LHB = ActiveSheet.Shapes.AddLine(dx, dy, dx, dy)
With LHB
For i = 1 To L
.Height = i
DoEvents
Next i
End With

'Ligne de gauche à droite :
Set LGD = ActiveSheet.Shapes. _
AddLine(dx, dy + L, dx, dy + L)
With LGD
For i = 1 To L
.Width = i
.Left = dx + i - .Width
DoEvents
Next i
End With

'Ligne de bas en haut :
Set LBH = ActiveSheet.Shapes. _
AddLine(dx + L, dy + L, dx + L, dy + L)
With LBH
For i = 1 To L
.Height = i
.Top = dy + L - .Height
DoEvents
Next i
End With

'Ligne de droite à gauche :
Set LDG = ActiveSheet.Shapes. _
AddLine(dx + L, dy, dx + L, dy)
With LDG
For i = 1 To L
.Width = i
.Left = dx + L - i
DoEvents
Next i
End With

'Les deux diagonales :
Set diag1 = ActiveSheet.Shapes. _
AddLine(dx, dy, dx + L, dy + L)
Set diag2 = ActiveSheet.Shapes. _
AddLine(dx, dy + L, dx + L, dy)

'Tentative avortée pour colorier les diagonales en rouge :
'diag1.ShapeRange.Line.ForeColor.SchemeColor = 10
'diag2.ShapeRange.Line.ForeColor.SchemeColor = 10
End Sub




1 2