tracer demi cercle graphique excel VBA Résolu

Question

Bonjour 
voilà je voudrai créer un graphique  dont je positionne sur l'abscisse deux points  qui constituent mon diametre du demi cercle que je veux tracer dans le graphique
Comment réaliser ce demicercle entre Pt1 sur l'abscisse et le Pt2 sur cette meme abscisse.
puis de l'origine 0,0 je veux qu'une droite se trace jusqu'a toucher  le précedent demi cercle
Y aurait il quelqu'un de  m'aider

Patrick L
POA

cs_Orohena · Accepted Answer

Pour le dessin du demi-cercle, peux-tu essayer le code suivant ?

Ne sachant quel demi-cercle tu veux afficher, je te donne les deux possibilités. 

Option Explicit
Type coordonnees
    x As Double
    y As Double
End TypeConst SUPERIEUR 1, INFERIEUR 2
'
Sub essai()
    Dim Pt1 As coordonnees
    Dim Pt2 As coordonnees    Pt1.x 100: Pt1.y 200                           ' coordonnées du point Pt1    Pt2.x 200: Pt2.y Pt1.x                         ' coordonnées du point Pt2
    trace_Demi_Cercle INFERIEUR, Pt1, Pt2    ' dessin du demi-cercle inférieur de diamètre Pt1, Pt2
End Sub
'
Sub trace_Demi_Cercle(ByVal lequel As Long, ByRef Pt1 As coordonnees, ByRef Pt2 As coordonnees)
    Dim centre As coordonnees, rayon As Double    centre.x (Pt2.x + Pt1.x) / 2: centre.y Pt1.y
    rayon = Abs(Pt2.x - Pt1.x)
    ActiveSheet.Shapes.AddShape(msoShapeArc, _
        centre.x, centre.y - rayon, rayon, rayon).Select
    With Selection
        .ShapeRange.Adjustments.Item(1) = 180
        If lequel = INFERIEUR Then
            .ShapeRange.Flip msoFlipVertical
            .Top = .Top + rayon
        End If
    End With
End Sub

Amicalement

cs_Orohena · Answer

Bonjour chevalier78

l'origine 0, 0 de quoi ?

Cordialement

cs_Orohena · Answer

Aïe, j'ai appelé une variable rayon, alors qu'elle aurait dû s'appeler diametre pour une meilleure clarté.

cs_Orohena · Answer

Hello Patrick

>> puis de l'origine 0,0 je veux qu'une droite se trace jusqu'a toucher  le précedent demi cercle

Tu as résolu cette question ? Si oui, peux-tu poster ta solution ?

Si non, précise-moi à quelle origine tu fais référence : celle de ton plan x, y ou celle de la feuille de calcul (coin supérieur gauche).

Amicalement

chevalier78 · Answer

Bonjour
Non a ce jour je n'ai pas trouvé la réponse pour tracer cette droite qui part du point x=0 et y=0  croisé de l' absisse et ordonnée. et qui viens rejoindre le cercle en tangeante en quelque sorte.

 en resumé le cercle se positionne sur l'axe des abcisse  dont le centre passe sur celle ci
en fonction du diamètre  et de sa position origine ex: y=0, x=50 (centre)
une droite doit etre tracée entre le point d'origine 0,0  et va toucher  en biais en montant le cercle  en un point .
Pas evident  a expliquer
Mais  merci quand même.

Patrick L
POA

cs_Orohena · Answer

Bonjour Patrick

C'est bien clair.
C'est un simple problème de trigo. Le triangle formé par la tangente, le rayon et l'axe des x est rectangle au point de tangence, ok ? Tu connais l'hypothénuse (abcisse du centre du cercle) et le côté opposé (rayon). Par conséquent, il t'est facile de calculer l'angle de la tangente.
Une fois connu l'angle, tu as juste à tracer un segment confondu avec l'axe des x et lui faire faire une rotation.
Je te laisse essayer, dis-moi si ça coince.

Amicalement

piloulac · Answer

Tu colles ces deux Subs dans un module puis tu lances la première DrawGraphTangente.
Dans les InputBox, tu donnes les cotes du cercle et de son écart à l'origine du graphe. (En pixels, ne dépasse pas 300) (L'écart du cercle à l'origine doit être significatif minimum 25 pixels)

Sub DrawGraphTangente()
nettoyerfeuille
Range("A1").Select


Dim x, y, A, B, angleorigine, anglecentre, ytangente, xtangente
Dim Dwg     As Object
Dim AngleD   As Single  'angles degrés
Dim AngleR  As Single   'en radians


B = InputBox("Rayon en pixels de 25 à 300")
If IsNumeric(B) = False Then Exit Sub
A = InputBox("Ecart par rapport à l'origine de 25 à 300")
If IsNumeric(A) = False Then Exit Sub
B = CInt(B)
A = CInt(A)
   
D = A + B       'distance centre/origine


X0 = 50 + D  'x origine
Y0 = 50            'y origin
Range("A1").Select
With ActiveSheet
For AngleD = 2 To 180 Step 2     'Degrees
        AngleR = Application.Radians(AngleD)
        x = B * Cos(AngleR) + X0
        y = B * Sin(AngleR) + Y0
            If AngleD = 2 Then
                'premier pas du cercle
                Set Dwg = .Drawings.Add(B + X0, Y0, x, y, True)
                Dwg.Interior.ColorIndex = xlNone
            Else
                'Add a vertex
                Dwg.AddVertex x, y
            End If
Next AngleD
End With
''grands axes
ActiveSheet.Shapes.AddLine(50, 50, 600, 50).Select
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
ActiveSheet.Shapes.AddLine(50, 50, 50, 400).Select
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle


'''' Un peu de trigo pour tracer la tangente
angleorigine = Application.WorksheetFunction.Asin(B / D)
angleorigine = Application.WorksheetFunction.Degrees(angleorigine)
anglecentre = 90 - angleorigine
anglecentre = Application.WorksheetFunction.Radians(anglecentre)
hauttangente = Sin(anglecentre)
hauttangente = hauttangente * B
hauttangente = hauttangente + 50
ecarttangente = Cos(anglecentre)
ecarttangente = ecarttangente * B
ecarttangente = 50 + A + B - ecarttangente
''tangente
ActiveSheet.Shapes.AddLine(50, 50, ecarttangente, hauttangente).Select
'''projections sur axes
ActiveSheet.Shapes.AddLine(ecarttangente, 50, ecarttangente, hauttangente).Select
 Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
   Selection.ShapeRange.Line.Weight = 1.5
ActiveSheet.Shapes.AddLine(50, hauttangente, ecarttangente, hauttangente).Select
 Selection.ShapeRange.Line.ForeColor.SchemeColor = 48
   Selection.ShapeRange.Line.Weight = 1.5

''''des infos en cellules
Range("A1").Formula = "Rayon"
Range("B1").Formula = B
Range("A2").Formula = "Distance OC"
Range("B2").Formula = D
ecarttangente = Format(ecarttangente, "# ##0.00")
Range("E1").Formula = "X " & ecarttangente
hauttangente = Format(hauttangente, "# ##0.00")
Range("E2").Formula = "Y " & hauttangente
Range("A1").Select
End Sub


Sub nettoyerfeuille()
'''supprimer toutes les lignes de graph
ActiveSheet.DrawingObjects.Select
    Selection.Delete


'' quelques formats
ActiveSheet.Cells.Clear
Range("E1").Font.FontStyle = "Gras"
Range("E1").Font.ColorIndex = 5
Range("E2").Font.FontStyle = "Gras"
Range("E2").Font.ColorIndex = 3        
    
''créer un bouton de commande
 ActiveSheet.Buttons.Add(640.5, 11.25, 51.75, 20.25).Select
    Selection.Characters.Text = "Graph"
    Selection.Name = "Boutongraph"
    Selection.OnAction = "DrawGraphTangente"
End Sub

Tracer demi cercle graphique excel VBA

7 réponses

Votre réponse

Discussions similaires