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

10 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
Sitting Hoax \(BM\)
Bonsoir
intéressant, sur le plan animation,
Serge Garnote a lancé un challenge pour une animation sur le théorème de
pythagore.
Je pense que ça ouvre des perspectives.
Pour la fin de la macro
'*********
Set diag1 = ActiveSheet.Shapes. _
AddLine(dx, dy, dx + L, dy + L)
diag1.Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Set diag2 = ActiveSheet.Shapes. _
AddLine(dx, dy + L, dx + L, dy)
diag2.Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
End Sub
AmicalemenT
Sitting Hoax

"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
AV
Il y a aussi cette piste (à explorer ?)

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub zz_Carré()
For i = 1 To 101
Start = Timer
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, i, i).Select
Application.ScreenUpdating = True
If i = 100 Then Exit Sub
Sleep (10)
Selection.Delete
Finish = Timer
Next
End Sub

AV
Avatar
Jp Pradier
Salut Serge

Une autre façon de faire un carré trouvé je ne sais plus ou : (à améliorer avec un compteur pour l'animation)

Sub test2()

Set myDocument = Worksheets(1)
With myDocument.Shapes.BuildFreeform(msoEditingCorner, 200, 200)
.AddNodes msoSegmentLine, msoEditingAuto, 200, 400
.AddNodes msoSegmentLine, msoEditingAuto, 400, 400
.AddNodes msoSegmentLine, msoEditingAuto, 400, 200
.AddNodes msoSegmentLine, msoEditingAuto, 200, 200
.ConvertToShape
End With

End Sub

j-p
Avatar
isabelle
on pourrait y ajouter
ActiveWindow.DisplayGridlines = False
pour faire plus joli.

est tu d'accord AV ?

isabelle


Il y a aussi cette piste (à explorer ?)

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub zz_Carré()
For i = 1 To 101
Start = Timer
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, i, i).Select
Application.ScreenUpdating = True
If i = 100 Then Exit Sub
Sleep (10)
Selection.Delete
Finish = Timer
Next
End Sub

AV


Avatar
garnote
Il me semble qu'on pourrait faire ça sans sélectionner la forme, non ?
Et là tu viens de me rappeler ce fameux challenge :

http://www.mathkang.org/swf/pythagore2.html

Pas sorti du bois !
Je démissionne de l'enseignement et me lance dans ce torride projet !

;-)))

Serge

"Sitting Hoax (BM)" a écrit dans le message de
news:
Bonsoir
intéressant, sur le plan animation,
Serge Garnote a lancé un challenge pour une animation sur le théorème de
pythagore.
Je pense que ça ouvre des perspectives.
Pour la fin de la macro
'*********
Set diag1 = ActiveSheet.Shapes. _
AddLine(dx, dy, dx + L, dy + L)
diag1.Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Set diag2 = ActiveSheet.Shapes. _
AddLine(dx, dy + L, dx + L, dy)
diag2.Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
End Sub
AmicalemenT
Sitting Hoax

"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
AV
est tu d'accord AV ?


Avec toi ? --> Toujours ! ;-)
Au fait ? De quoi s'agit-il ? ;-))

AV

Avatar
garnote
Mais c'est que je tiens à mes petits déplacements
sur chaque côté, moi ! En tout cas, je retiens ton
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
que j'égare sans cesse.

Serge



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

Il y a aussi cette piste (à explorer ?)

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub zz_Carré()
For i = 1 To 101
Start = Timer
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, i, i).Select
Application.ScreenUpdating = True
If i = 100 Then Exit Sub
Sleep (10)
Selection.Delete
Finish = Timer
Next
End Sub

AV




Avatar
isabelle
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
garnote
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
AV
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é.


C'était pour rire...!
Le sujet ne me passionnant pas outre mesure, je vous laisse entre expatriés !
;-)
AV


1 2