Coordonnée forme / centre d'une forme

**auditrix** · 21/03/2016, 08h31

Bonjour à tous,

J'aimerai réaliser une macro qui me permette de tracer un cercle au centre d'un rectangle. Pour cela j'ai tout d'abord insérer une image avec un formulaire X et utiliser mousemov afin de positionner le rectangle où l'on veut grâce aux coordonnées.
Maintenant j'aimerai tracer un cercle à partir du centre de rectangle sachant que le rectangle peut être orienté selon différents axes de rotation (ainsi pour avoir le centre il ne suffit pas de faire le coordonnée du point en haut à gauche moins la longueur du rectangle/2 et moins la largeur du rectangle/2).
Pour essayer de contourner mon problème, j'ai créer un connecteur au centre de la forme dans le but d'obtenir ces coordonnées et le centre du trait sera le centre de mon rectangle. le problème c'est que je n'arrive pas à obtenir les coordonnées du connecteur.
Quelqu'un à t-il une idée? ou une autre idée que la mienne pour avoir le centre du rectangle ?

Ci-dessous ma macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub ze(ByVal centreX As Single, ByVal centrey As Single, ByVal longueur As Single, ByVal largeur As Single, ByVal angle As Single, ByVal pointx1 As String, ByVal pointy1 As String, ByVal pointx2 As String, ByVal pointy2 As String)
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, centreX, centrey, longueur, largeur).Select
    Selection.ShapeRange.IncrementRotation angle
    Selection.ShapeRange.Fill.Visible = msoFalse
    Cells(2, 31) = ActiveWindow.Selection.ShapeRange(1).Name
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 0, 0, 0, 0).Select
    Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes(Cells(2, 31)), 1
    Selection.ShapeRange.ConnectorFormat.EndConnect ActiveSheet.Shapes(Cells(2, 31)), 3
    Cells(3, 29) = Selection.ShapeRange.ConnectorFormat.BeginX 'cette ligne ne marche pas
    Cells(3, 30) = Selection.ShapeRange.ConnectorFormat.BeginY 'cette ligne ne marche pas
    Cells(3, 31) = Selection.ShapeRange.ConnectorFormat.EndX 'cette ligne ne marche pas
    Cells(3, 32) = Selection.ShapeRange.ConnectorFormat.EndY 'cette ligne ne marche pas
    'Cells(2, 29) = (pointx1 + pointx2) / 2
    'Cells(2, 30) = (pointy1 + pointy2) / 2
 
    End Sub
 
Sub trace_ze()
    Dim centreX As Single
    Dim centrey As Single
    Dim longueur As Single
    Dim largeur As Single
    'For i = 2 To 47
    longueur = Cells(2, 26)
    largeur = Cells(2, 27)
    centreX = Cells(2, 24)
    centrey = Cells(2, 25)
    angle = Cells(2, 28)
    pointx1 = Cells(2, 32)
    pointy1 = Cells(2, 33)
    pointx2 = Cells(2, 34)
    pointy2 = Cells(2, 35)
    ze centreX, centrey, longueur, largeur, angle, pointx1, pointy1, pointx2, pointy2
    'Next i
End Sub

Merci d'avance,

Marie

**parmi** · 21/03/2016, 13h50

Bonjour,

Et si tu trouvais le centre avant de faire la rotation ?
Si je ne me trompe pas, le centre demeure le même lors de la rotation.

**auditrix** · 21/03/2016, 14h12

Bonjour,

Merci pour la réponse,
Mais non les coordonnées du centre du rectangle en reste pas les mêmes lorsqu'on lui inflige un angle de rotation. C'est pour ça que je dois trouver les coordonnées du centre après la rotation du rectangle.

Marie

**cerede2000** · 21/03/2016, 14h33

Bonjour,

Voici des fonctions qui te renvoi les valeurs réel en tenant compte de la rotation appliqué

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Function RealLeft(shp As Variant) As Single
    Dim sngRotAngRad As Single
 
    sngRotAngRad = shp.Rotation * 3.14159 / 180
    RealLeft = (shp.Left + shp.Width / 2) - (shp.Height * Abs(Sin(sngRotAngRad)) + shp.Width * Abs(Cos(sngRotAngRad))) / 2
End Function
 
Function RealTop(shp As Variant) As Single
    Dim sngRotAngRad As Single
 
    sngRotAngRad = shp.Rotation * 3.14159 / 180
    RealTop = (shp.Top + shp.Height / 2) - (shp.Width * Abs(Sin(sngRotAngRad)) + shp.Height * Abs(Cos(sngRotAngRad))) / 2
End Function
 
Function RealWidth(shp As Variant) As Single
    Dim sngRotAngRad As Single
 
    sngRotAngRad = shp.Rotation * 3.14159 / 180
    RealWidth = shp.Height * Abs(Sin(sngRotAngRad)) + shp.Width * Abs(Cos(sngRotAngRad))
End Function
 
Function RealHeight(shp As Variant) As Single
    Dim sngRotAngRad As Single
 
    sngRotAngRad = shp.Rotation * 3.14159 / 180
    RealHeight = shp.Width * Abs(Sin(sngRotAngRad)) + shp.Height * Abs(Cos(sngRotAngRad))
End Function
 
Function RealRight(shp As Variant) As Single
    RealRight = RealLeft(shp) + RealWidth(shp)
End Function
 
Function RealBottom(shp As Variant) As Single
    RealBottom = RealTop(shp) + RealHeight(shp)
End Function

Par contre parmi a raison, le centre ne change pas après rotation. Sauf s'il y a déplacement.

**auditrix** · 21/03/2016, 15h13

Bonjour,

Merci pour la réponse,

Oui en effet le centre ne bouge pas je pensais qu'en modifiant les coordonnées de trois points du rectangle cela modifier les coordonnées de son centre, mais non. Merci.

Par contre, désolé mais comment ta macro fonctionne ? je n'ai pas l'habitude d'utiliser des fonctions plutôt des sub.

Merci

Marie

**cerede2000** · 21/03/2016, 15h19

Une fonction est une sub qui renvoi une valeur.

Donc

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

VarX = MaFonction(ParametresX)

Elles permettes de connaitre les valeurs réel lorsque ta shape à tournée.
Car les propriétés Top, Left ne bougent pas après rotation elle restent identiques.
Avec les fonctions données au dessus, tu obtiendra les vrais valeurs après rotation.

De quoi te permettre de recalculer le centre si besoin.

**auditrix** · 21/03/2016, 15h42

Merci pour ta réponse

j'ai donc fait une sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub essai()
 
gauche = RealLeft("Rectangle 20")
Top = RealTop("Rectangle 20")
largeur = RealWidth("Rectangle 20")
hauteur = RealHeight("Rectangle 20")
droite = RealRight("Rectangle 20")
bas = RealBottom("Rectangle 20")
 
End Sub

Le problème c'est que la macro plante dans les functions au niveau de cette ligne :
sngRotAngRad = shp.Rotation * 3.14159 / 180
avec comme erreur "objet requis"

Ton code va me permettre d'avoir les coordonnées du rectangle voulu ?

Merci

**cerede2000** · 21/03/2016, 15h52

Les fonctions attendent un objet de type Shape.
Hors tu passe un string

Donc ça ne peux pas fonctionner.

Il faut faire comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Dim shp20 As Shape
Dim gauche As single
Set shp20 = ActiveSheet.Shapes("Rectangle 20")
gauche = RealLeft(shp20)

En effet les fonctions te donnerons les bonnes valeurs en fonction de la rotation.

Tu n'auras plus qu'a calculer le centre

**auditrix** · 21/03/2016, 16h08

Ok super merci beaucoup ça marche, désolé de t'avoir embêté avec ça.

Juste une dernière question, les coordonnées que donne ta macro sont en point ? car les coordonnées que j'obtiens en utilisant mousemove avec la macro suivante sont différents des tiens :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Cells(1, 13) = "X = " & X & " Y = " & Y
End Sub

Je m'explique:

j'ai mis un plan sur lequel j'ai les coordonnées grâce à mousemove ensuite je crée un rectangle selon les coordonnées que je veux (trouvé grâce à mouse move) avec cette macro:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sub ze(ByVal centreX As Single, ByVal centrey As Single, ByVal longueur As Single, ByVal largeur As Single, ByVal angle As Single)
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, centreX, centrey, longueur, largeur).Select
    Selection.ShapeRange.IncrementRotation angle
    Selection.ShapeRange.Fill.Visible = msoFalse
    Cells(2, 31) = ActiveWindow.Selection.ShapeRange(1).Name
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub trace_ze()
    Dim centreX As Single
    Dim centrey As Single
    Dim longueur As Single
    Dim largeur As Single
    longueur = Cells(2, 26)
    largeur = Cells(2, 27)
    centreX = Cells(2, 24)
    centrey = Cells(2, 25)
    angle = Cells(2, 28)
    ze centreX, centrey, longueur, largeur, angle
End Sub

donc logiquement les coordonnées que j'entre devrait être les mêmes que ton top et left mais ce n'est pas le cas. Je me dis que c'est peut etre un problème d'unité.

Qu'en penses tu ?

Merci d'avance,

**cerede2000** · 21/03/2016, 16h19

Évite de répondre avec citation à chaque fois, ça ne sert a rien

C'est quoi que tu appel un plan ?

Peux tu poster ton code ou ton fichier Excel afin que je puisse voir ?

**auditrix** · 21/03/2016, 16h28

Ok j'ai mis la pièce jointe (je l'espère).

Ok pour les citations, je ne sais pas la différence.

Le plan c'est une zone géographique , dans une image du formulaire X j'ai insérer une vue du ciel et avec mousemove je peux connaitre les coordonnées.

Mon but est grâce aux coordonnées sur le plan d'insérer un rectangle à l'endroit que je veux et ensuite de tracer un cercle au centre du rectangle.

Merci,

Marie

**cerede2000** · 21/03/2016, 16h36

Oula, oula !

Ton classeur rame à mort !

Tu as du créer des tonnes de Shapes qu'on ne vois pas, dès que je fais une action ça quasi-plante Excel (i7 2.6Ghz, 16Go Ram SSD 850 Evo....).

**auditrix** · 21/03/2016, 16h38

Oui c'est possible car j'arrête pas d'en créer mais je les supprime à la main.

Désolé, je ne suis pas experte en vba.

**cerede2000** · 21/03/2016, 16h56

Pas de souci

C'est juste que c'était hyper lourd, j'ai fait une petite sub pour tout virer

Donc, j'ai fait un test vite fait entre la position de la souris sur le plan que tu affiche dans la feuille et la valeur renvoyé par top de RealTop.
C'est cohérent.

Je te propose un petit test :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Cells(1, 13) = "X = " & X & " Y = " & Y
    Dim shp20 As Shape
    Dim gauche As Single
    Set shp20 = ActiveSheet.Shapes("Rectangle 4364")
    shp20.Top = Y + (shp20.Top - RealTop(shp20))
    shp20.Left = X + (shp20.Left - RealLeft(shp20))
End Sub

Le rectangle suis ta souris

Edit : Vite fais :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Cells(1, 13) = "X = " & X & " Y = " & Y
    Dim shp20 As Shape
    Dim gauche As Single
    Set shp20 = ActiveSheet.Shapes("Rectangle 4364")
 
    he = RealHeight(shp20)
    wi = RealWidth(shp20)
    shp20.Top = Y + (shp20.Top - RealTop(shp20)) - (he / 2)
    shp20.Left = X + (shp20.Left - RealLeft(shp20)) - (wi / 2)
End Sub

La souris est au milieu du rectangle après son déplacement

**auditrix** · 21/03/2016, 17h05

Ok merci beaucoup en effet c'est bon!

Merci encore,

Une dernière chose comment tu as fait pour supprimer toutes les formes, car je suis allée accueil -->rechercher et sélection --> volet sélection mais je les supprime un à un et c'est super long.

merci

**cerede2000** · 21/03/2016, 18h09

Hihi très simple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
sub deleteAllShapes()
Dim shp As Shape
 
For each shp in Activesheet.Shapes
shp.delete
Next
End Sub

Attention ça supprimera TOUTES les Shapes !
Donc même tes boutons et ton image plan.

**auditrix** · 25/03/2016, 15h55

Merci beaucoup pour ton aide !

Coordonnée forme / centre d'une forme [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager