Tracer cercle vba excel

Signaler
Messages postés
91
Date d'inscription
vendredi 15 janvier 2010
Statut
Membre
Dernière intervention
19 octobre 2012
-
Messages postés
14823
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
9 octobre 2021
-
bonjour je souhaite tracer un cercle à l'aide de visual basic
cela fonctionne lorsque je rentre manuellement les données des variables e et f (coordonée du centre). Mais lorsque je fais appel à ces variables, ça ne fonctionne plus

Merci pour votre aide


Sub tracercle()
ActiveSheet.Shapes.AddShape(msoShapeOval, e, f, 20, 20).Select
End Sub

Sub trace_cercle()
Dim e As String
Dim f As String
e = 20
f = 30
Call tracercle
End Sub

12 réponses

Messages postés
91
Date d'inscription
vendredi 15 janvier 2010
Statut
Membre
Dernière intervention
19 octobre 2012
1
ok Merci d'avoir répondu si vite. j'ai appliqué tes instructions, et ça à marché dans un premier temps. J'ai voulu rajouter un paramètre couleur, et depuis ça ne fonctionne plus.

voici ce que j'ai tester (sans couleur)
Option Explicit

Sub tracercle(ByVal pcentreX As Single, ByVal pcentrey As Single)
    ActiveSheet.Shapes.AddShape(msoShapeOval, pcentreX, pcentrey, 20, 20).Select
End Sub

Sub trace_cercle()
    Dim pcentreX As Single
    Dim pcentrey As Single
    pcentreX = 100
    pcentrey = 100
    Call tracercle
End Sub


et avec couleur.

Sub tracerclecoul(ByVal pcentreX As Single, ByVal pcentrey As Single, ByRef coul As String)
    ActiveSheet.Shapes.AddShape(msoShapeOval, pcentreX, pcentrey, 20, 20).Select
    Selection.ShapeRange.Fill.ForeColor.RGB = coul
End Sub

Sub trace_cerclecoul()
    Dim pcentreX As Single
    Dim pcentrey As Single
    Dim coul As String
    pcentreX = 60
    pcentrey = 60
    If Cells(1, 1) = "o" Then
    coul = RGB(250, 0, 0)
    Else
    coul = RGB(0, 250, 0)
    End If
    Call tracerclecoul
End Sub
Messages postés
14823
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
9 octobre 2021
156
Bonjour,

Ton problème est lié à la portée des variables.
Pense à TOUJOURS mettre "Option Explicit en haut de tes modules de code, cela te force à déclarer tes variables.

Pour faire simple :
Les variables "e" et "f" ne sont valables que dans la Sub trace_cercle.

Il faut utiliser des paramètres pour ça :
Sub tracercle(Byval pCentreX as single,Byval pCentreY as single)
    ActiveSheet.Shapes.AddShape(msoShapeOval, pCentreX , pCentreY , 20, 20).Select
End Sub

Sub trace_cercle()
    Dim e As Single
    Dim f As Single
    e = 20
    f = 30
    tracercle e,f
End Sub


Evite aussi les types non adaptés, par exemple dans ton code des String pour stocker des nombres, ça t'évitera pas mal d'erreur.

Messages postés
91
Date d'inscription
vendredi 15 janvier 2010
Statut
Membre
Dernière intervention
19 octobre 2012
1
ok j'ai résolu le pb N°1 sans couleur

j'vais oublier à la fin
tracercle pcentreX, pcentrey


Mais mon problème pour inclure la paramètre "couleur" demeure toujours.
Messages postés
91
Date d'inscription
vendredi 15 janvier 2010
Statut
Membre
Dernière intervention
19 octobre 2012
1
finalement plus de problème !

tout est arrangé

MERCI à toi pour ton aide
Messages postés
14823
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
9 octobre 2021
156
Bonjour,

Pourquoi tu persévère à faire des données en String à la place du type numérique quand cela est le cas ?
RGB retourne un Long, donc ce n'est pas :
Dim coul As String
Mais
Dim coul As Long

Ensuite, tu n'a pas ajouté le paramètre dans l'appel de la sub.
Tu ajoutes un :
,coul
et ça devrait passer.

Préfère passer les paramètres en ByVal, sauf si cela est absolument nécessaire de passer en ByRef.

Messages postés
91
Date d'inscription
vendredi 15 janvier 2010
Statut
Membre
Dernière intervention
19 octobre 2012
1
J'essaye à présent de rajouter cette procédure dans une macro qui fonctionnait auparavant.

Le but de cette macro est de tracer successivement des segments en fonction de coordonnées listées dans un tableau.
Les coordonnées manquantes sont matérialisés par la lettre "t", et sont calculés à l'aide des coordonnées du segment connues (qui inclut ce point).

Mon problème est que la macro ne trace ni les segment ni les ploints et affiche le message "erreur de compilation: argument non facultatif"

comment rectifier ce souci?

voici ma macro:

Option Explicit

Sub traceligne(ByVal a As Single, ByVal b As Single, ByVal a As Single, ByVal d As Single, ByVal c As Single, ByRef coul As String)
'coordonées
    ActiveSheet.Shapes.AddLine(b, a, d, c).Select
'épaisseur
    Selection.ShapeRange.Line.Weight = 3
'couleur
    Selection.ShapeRange.Line.ForeColor.RGB = coul

End Sub

Sub tracerclecoul(ByVal pcentreX As Single, ByVal pcentrey As Single, ByRef coul As String)
'coordonées
    ActiveSheet.Shapes.AddShape(msoShapeOval, pcentreX, pcentrey, 20, 20).Select
'couleur
    Selection.ShapeRange.Fill.ForeColor.RGB = coul
End Sub

Sub graphe()

'incrément_boucle
Dim n As Single
Dim m As Single
'coordonées_segment
Dim a As Single
Dim b As Single
Dim c As Single
Dim d As Single
'coordonées_cercle
Dim pcentreX As Single
Dim pcentrey As Single
Dim coul As String


For n = 2 To 4
a = 0
b = 0
c = 0
d = 0
pcentrey = 0
pcentreX = 0

If Cells(1, n) = "o" Then
coul = RGB(200, 0, 0)
End If
If Cells(1, n) = "t" Then
coul = RGB(0, 200, 0)
End If
If Cells(1, n) = "g" Then
coul = RGB(0, 0, 200)
End If


     For m = 2 To 10
         If Cells(m, n) = "t" Then
         pcentrey = Cells(m, 1)
         End If
         If a = 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
          a = Cells(m, 1)
          b = Cells(m, n)
         End If
         
         If a <> 0 And c = 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
          c = Cells(m, 1)
          d = Cells(m, n)
          traceligne b, a, d, c, coul
         
             If pcentrey <> 0 Then
             pcentreX = CInt(((d - b) / (c - a) * (pcentrey - a)) + b)
             tracerclecoul pcentreX, pcentrey, coul
             End If
             
         End If
         
         If c <> 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
          a = c
          b = d
          c = Cells(m, 1)
          d = Cells(m, n)
          traceligne b, a, d, c, coul
         
             If pcentrey <> 0 Then
             pcentreX = CInt(((d - b) / (c - a) * (pcentrey - a)) + b)
             tracerclecoul pcentreX, pcentrey, coul
             End If
             
         End If
      Next m
Next n
End Sub
Messages postés
91
Date d'inscription
vendredi 15 janvier 2010
Statut
Membre
Dernière intervention
19 octobre 2012
1
Merci NHenry j'avais pas lu ta réponse précédent, je viens d'en prendre compte dans la suite de ma macro

sauf erreur de ma part cela donne:

Option Explicit

Sub traceligne(ByVal a As Single, ByVal b As Single, ByVal a As Single, ByVal d As Single, ByVal c As Single, ByVal coul As Long)
'coordonées
    ActiveSheet.Shapes.AddLine(b, a, d, c).Select
'épaisseur
    Selection.ShapeRange.Line.Weight = 3
'couleur
    Selection.ShapeRange.Line.ForeColor.RGB = coul

End Sub

Sub tracerclecoul(ByVal pcentreX As Single, ByVal pcentrey As Single, ByVal coul As Long)
'coordonées
    ActiveSheet.Shapes.AddShape(msoShapeOval, pcentreX, pcentrey, 20, 20).Select
'couleur
    Selection.ShapeRange.Fill.ForeColor.RGB = coul
End Sub

Sub graphe()

'incrément_boucle
Dim n As Single
Dim m As Single
'coordonées_segment
Dim a As Single
Dim b As Single
Dim c As Single
Dim d As Single
'coordonées_cercle
Dim pcentreX As Single
Dim pcentrey As Single
Dim coul As String


For n = 2 To 4
a = 0
b = 0
c = 0
d = 0
pcentrey = 0
pcentreX = 0

If Cells(1, n) = "o" Then
coul = RGB(200, 0, 0)
End If
If Cells(1, n) = "t" Then
coul = RGB(0, 200, 0)
End If
If Cells(1, n) = "g" Then
coul = RGB(0, 0, 200)
End If


     For m = 2 To 10
         If Cells(m, n) = "t" Then
         pcentrey = Cells(m, 1)
         End If
         If a = 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
          a = Cells(m, 1)
          b = Cells(m, n)
         End If
         
         If a <> 0 And c = 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
          c = Cells(m, 1)
          d = Cells(m, n)
          traceligne b, a, d, c, coul
         
             If pcentrey <> 0 Then
             pcentreX = CInt(((d - b) / (c - a) * (pcentrey - a)) + b)
             tracerclecoul pcentreX, pcentrey, coul
             End If
             
         End If
         
         If c <> 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
          a = c
          b = d
          c = Cells(m, 1)
          d = Cells(m, n)
          traceligne b, a, d, c, coul
         
             If pcentrey <> 0 Then
             pcentreX = CInt(((d - b) / (c - a) * (pcentrey - a)) + b)
             tracerclecoul pcentreX, pcentrey, coul
             End If
             
         End If
      Next m
Next n
End Sub


mais le message "erreur de compilation: argument non facultatif" reste présent
Messages postés
14823
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
9 octobre 2021
156
Bonjour,

Ta ligne :
Sub traceligne(ByVal a As Single, ByVal b As Single, ByVal a As Single, ByVal d As Single, ByVal c As Single, ByVal coul As Long)

Ne comporte pas une erreur ?

De plus, pense à nommer de manière lisible tes variables.

A quoi servent a, b, c, d ?
Ce sont les points, je suppose, alors pense à les nommer par exemple X1, Y1, X2, Y2, ce sera plus clair.

Option Explicit

Sub traceligne(ByVal a As Single, ByVal b As Single, ByVal d As Single, ByVal c As Single, ByVal pColor As Long)
    'coordonées
    ActiveSheet.Shapes.AddLine(b, a, d, c).Select
    'épaisseur
    Selection.ShapeRange.Line.Weight = 3
    'couleur
    Selection.ShapeRange.Line.ForeColor.RGB = pColor
End Sub

Sub tracerclecoul(ByVal pCentreX As Single, ByVal pCentrey As Single, ByVal pColor As Long)
    'coordonées
    ActiveSheet.Shapes.AddShape(msoShapeOval, pcentreX, pcentrey, 20, 20).Select
    'couleur
    Selection.ShapeRange.Fill.ForeColor.RGB = pColor
End Sub

Sub graphe()

    'incrément_boucle
    Dim n As Single
    Dim m As Single
    'coordonées_segment
    Dim a As Single
    Dim b As Single
    Dim c As Single
    Dim d As Single
    'coordonées_cercle
    Dim lCentreX As Single
    Dim lCentreY As Single
    Dim lColor As Long

    For n = 2 To 4
        a = 0
        b = 0
        c = 0
        d = 0
        lcentrey = 0
        lcentreX = 0

        If Cells(1, n) = "o" Then
            lColor = RGB(200, 0, 0)
        End If
        If Cells(1, n) = "t" Then
            lColor = RGB(0, 200, 0)
        End If
        If Cells(1, n) = "g" Then
            lColor = RGB(0, 0, 200)
        End If

         For m = 2 To 10
             If Cells(m, n) = "t" Then
                lcentrey = Cells(m, 1)
            End If
            If a = 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
                a = Cells(m, 1)
                b = Cells(m, n)
            End If

            If a <> 0 And c = 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
                c = Cells(m, 1)
                d = Cells(m, n)
                traceligne a, b, d, c, lColor

                If lcentrey <> 0 Then
                    lcentreX = CInt(((d - b) / (c - a) * (lcentrey - a)) + b)
                    tracerclecoul lcentreX, lcentrey, lColor
                End If

            End If

            If c <> 0 And Cells(m, n) <> "" And Cells(m, n) <> "t" Then
                a = c
                b = d
                c = Cells(m, 1)
                d = Cells(m, n)
                traceligne b, a, d, c, lColor

                If lcentrey <> 0 Then
                    lcentreX = CInt(((d - b) / (c - a) * (lcentrey - a)) + b)
                    tracerclecoul lcentreX, lcentrey, lColor
                End If

            End If
        Next m
    Next n
End Sub


Messages postés
91
Date d'inscription
vendredi 15 janvier 2010
Statut
Membre
Dernière intervention
19 octobre 2012
1
j'ai corrigé la première ligne par
Sub traceligne(ByVal b As Single, ByVal a As Single, ByVal d As Single, ByVal c As Single, ByVal c As Single, ByVal coul As Long)


mais pas d'améliorations ...
Messages postés
91
Date d'inscription
vendredi 15 janvier 2010
Statut
Membre
Dernière intervention
19 octobre 2012
1
OK toutes mes excuses j'avais recopier 2 fois la variable C

Tu as bien raison je vais également modifier l'appellation de mes variables j'y verrai bien plus clair.

merci pour ta contribution qui m'est très précieuse.

Je suis encore loin de ce à quoi je souhaite parvenir ... mais ça avance !
Messages postés
14823
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
9 octobre 2021
156
Bonjour,

Pourquoi 2 fois le paramètre c ?

Messages postés
14823
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
9 octobre 2021
156
Dsl, je n'avais pas vu le message précédent le mien (pas vu qu'il y avait 2 pages)