Discussion :

[maxicobra]

Bonjour, je fais suite à une discussion à un sujet que j'ai ouvert (Double clic sur image active X). Mon problème évoluant et se compliquant je propose d'ouvrir un autre sujet

Ceux qui veulent voir le sujet initial:
http://www.developpez.net/forums/d15...x/#post8614539


Voilà la problématique:

J'ai un code qui me sers à enregistrer des coordonnées quand je clic sur un plan.
Celui-ci (il fonctionne):

Code :

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

1
2
3
4
5
Private Sub Image1_Click()
 
     Cells(3, 5).Resize(1, 2).Copy Cells(Rows.Count, 2).End(xlUp)(2)
 
End Sub

Ce que je souhaiterai, c'est que lorsque je clic sur ma map, j'enregistre ma coordonnées (maintenant c'est OK), mais que simultanément je place une "forme" (style un cercle) avec un numéro dedans là où j'ai cliqué. Ce numéro doit prendre +1 à chaque clic (car je place une trentaine de point sur ce plan).

Je sais que ça doit être faisable, mais bien short quand même... Je trouve pas trop sur le net...
Le code que je peux vous donner c'est, insertion d'une forme avec numéro 1 (avec enregistrement auto de 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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
ActiveSheet.Shapes.AddShape(msoShapeOval, 571.5, 33, 18, 18).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    Application.CommandBars("Format Object").Visible = False
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 2.75
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "1"
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1). _
        ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignLeft
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).Font
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
        .Fill.ForeColor.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 11
        .Name = "+mn-lt"
    End With
    With Selection.ShapeRange.TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        .HorizontalAnchor = msoAnchorNone
    End With
    Selection.ShapeRange.TextFrame2.MarginLeft = 5.6692913386
    Selection.ShapeRange.TextFrame2.MarginLeft = 2.8346456693
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginLeft = 2.8346456693
    Application.CommandBars("Format Object").Visible = False

Si vous avez des billes je suis très friant

[maxicobra]

Pour infos, j'arrive à créer mes pastilles en fonction de numéro de la mesure. Rest plus qu'à la placer dans mon référenciel de coordonnée de l'image active x. Qui fait 700 de large et 400 de hauteur.

Le code pour la pastille:

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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Private Sub Ajout_Click()
Dim i As Integer
 
i = Cells(2, 14).Value
 
With ActiveSheet
 
        ' Ajout d'une forme via expression.AddShape ( type , Gauche , Haut , Largeur , Hauteur )
        Set forme = .Shapes.AddShape(msoShapeOval, 571.5, 33, 18, 18)
          forme.Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
 
    End With
 
     With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 2.75
    End With
 
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = i
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1). _
        ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignLeft
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).Font
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
        .Fill.ForeColor.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 11
        .Name = "+mn-lt"
    End With
    With Selection.ShapeRange.TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        .HorizontalAnchor = msoAnchorNone
    End With
        Selection.ShapeRange.TextFrame2.MarginLeft = 5.6692913386
    Selection.ShapeRange.TextFrame2.MarginLeft = 2.8346456693
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginLeft = 2.8346456693
               End With
End Sub

[Invité]

Bonjour,


Comme suite à la discussion d'hier (et à la remarque de Joe que je salue), le fichier Pièce jointe 208184 contient une solution pour représenter des points sur une carte. Ce fichier ne contient pas la méthode pour générer les coordonnées puisque visiblement vous avez trouvé le système (cf votre message d'hier).

Les coordonnées représentées, le sont relativement à la carte (700, 400 points).


Le code :

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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
 
Option Explicit
 
Private ShCarte As Worksheet
Private Forme As Shape
Private CarteEtudiee As Shape
 
 
Sub RepresenterLesPointsSurUneCarte()
 
Dim AireDesPointsARepresenter As Range
Dim CellulePoint As Range
Dim LigneDeTitre As Long
Dim DerniereLigne As Long
 
    Set ShCarte = Sheets("Feuil1")
 
    With ShCarte
 
        ' Suppression des points existants
        '---------------------------------
        For Each Forme In .Shapes
            If Mid(Forme.Name, 1, 5) = "Point" Then Forme.Delete
        Next Forme
 
        ' Définition de l'aire des points
        '--------------------------------
        LigneDeTitre = 10
        DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set AireDesPointsARepresenter = .Range(.Cells(LigneDeTitre + 1, 1), .Cells(DerniereLigne, 1))
 
        ' Définition de la carte
        '-----------------------
        Set CarteEtudiee = ShCarte.Shapes("Image 1")
 
        ' Création des points
        '--------------------
        For Each CellulePoint In AireDesPointsARepresenter
            CreerUneCoordonnee ShCarte, CellulePoint, CellulePoint.Offset(0, 1), CellulePoint.Offset(0, 2), CarteEtudiee
        Next CellulePoint
 
 
        Set CarteEtudiee = Nothing
        Set AireDesPointsARepresenter = Nothing
        Set ShCarte = Nothing
 
    End With
 
 
End Sub
 
 
Sub CreerUneCoordonnee(ByVal FeuilleCoordonnee As Worksheet, ByVal Longitude As Double, ByVal Latitude As Double, ByVal NumeroDOrdre As String, ByVal CarteEnCours As Shape)
 
 
    With FeuilleCoordonnee
 
         Set Forme = .Shapes.AddShape(msoShapeOval, Longitude + CarteEnCours.Left, Latitude + CarteEnCours.Top, 18, 18)
         With Forme
              .Name = "Point " & NumeroDOrdre
              With .Fill
                   .Visible = msoTrue
                   .ForeColor.ObjectThemeColor = msoThemeColorBackground1
              End With
              With .Line
                   .Visible = msoTrue
                   .Weight = 1.5
              End With
              With .TextFrame2
                   .VerticalAnchor = msoAnchorMiddle
                   .WordWrap = msoFalse
                   With .TextRange
                        .Text = NumeroDOrdre
                        .ParagraphFormat.Alignment = msoAlignCenter
                        With .Font
                             .Size = 8
                             .Name = "Arial"
                             .Bold = True
                             .Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
                        End With
                   End With
              End With
         End With
         Set Forme = Nothing
 
   End With
 
 End Sub
 
Sub SupprimerLesPointsSurUneCarte()
 
    Set ShCarte = Sheets("Feuil1")
 
    With ShCarte
 
        ' Suppression des points existants
        '---------------------------------
        For Each Forme In .Shapes
            If Mid(Forme.Name, 1, 5) = "Point" Then Forme.Delete
        Next Forme
 
        Set ShCarte = Nothing
 
    End With
 
End Sub

Le résultat se présente sous cette forme :


Pièce jointe 208185

Pour revenir à votre demande initiale qui est de générer les points au fur et à mesure du pointage sur la carte, il suffirait de lancer la macro CreerUneCoordonnee sur l'événement Worksheet_Change lors de l'incrémentation du numéro du point.


Cordialement.

Cf également : Generateur de formes sous excel

[maxicobra]

Bonjour,

Alors hier j'ai réussis (par moi même et je suis très content ) à faire ce que je voulais.
Finalement le code doit être assez proche que le votre Eric.

Je met le code ici, si ça peut aider quelqu'un. Mon code est dans l'action du clic. Et place donc ma pastille incrémenté sur ma souris.

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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Private Sub Image1_Click()
 Dim i As Integer
 Dim x As Integer
Dim y As Integer
x = Cells(2, 15).Value
y = Cells(2, 16).Value
     Cells(3, 5).Resize(1, 2).Copy Cells(Rows.Count, 2).End(xlUp)(2)
 
 i = Cells(2, 14).Value
 
With ActiveSheet
 
        ' Ajout d'une forme via expression.AddShape ( type , Gauche , Haut , Largeur , Hauteur )
        Set forme = .Shapes.AddShape(msoShapeOval, 571.5, 33, 18, 18)
          forme.Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
 
    End With
 
     With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 2.75
    End With
 
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = i
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1). _
        ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignLeft
    End With
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).Font
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
        .Fill.ForeColor.TintAndShade = 0
        .Fill.ForeColor.Brightness = 0
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 11
        .Name = "+mn-lt"
    End With
    With Selection.ShapeRange.TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        .HorizontalAnchor = msoAnchorNone
    End With
        Selection.ShapeRange.TextFrame2.MarginLeft = 5.6692913386
    Selection.ShapeRange.TextFrame2.MarginLeft = 2.8346456693
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginLeft = 2.8346456693
    'placer la pastille
    Selection.ShapeRange.Top = y
    Selection.ShapeRange.Left = x
 
               End With
End Sub

Les variables x et y sont faites de sortent à bien replacer ma pastille sur ma souris (du bricolage)