Rectangle en fonction d'excel Fermé

Question

Bonjour, je voudrais savoir comment on rédige les codes pour tracer un rectangle sur VBA a partir de donnée dans un tableau excel : (les lignes de chiffres commencent en ligne 3), voilà ce que j'ai trouvé mais qui n'est pas encore au point 

        A             B       C
Coordonées 	Y	Z	
Tole Pt Y1-Z1	-100	-110	
Tole Pt Y2-Z1	100	-110	
Tole Pt Y2-Z2	100	110	
Tole Pt Y1 -Z2	-100	110	
Tole Pt Y1-Z1	-100	-110	R Φ
Boulon 1	-70	-80	8
Boulon 2	70	-80	8
Boulon 3	-70	80	8
Boulon 4	70	80	8


Sub dessin()
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.DrawingObjects.Delete
        
     Dim A As Integer
     Dim AA As Integer
    Dim B As Integer
    Dim BB As Integer
    Dim C As Integer
    Dim CC As Integer
     Dim D As Integer
     Dim DD As Integer
  
     A = Sheets("tracé").Cells(3, 2).Select                 ("tracé") est le nom de ma feuille dans excel
     AA = Sheets("tracé").Cells(3, 3).Select
     B = Sheets("tracé").Cells(4, 2).Select
     BB = Sheets("tracé").Cells(4, 3).Select
     C = Sheets("tracé").Cells(5, 2).Select
     CC = Sheets("tracé").Cells(5, 3).Select
     D = Sheets("tracé").Cells(6, 2).Select
     DD = Sheets("tracé").Cells(6, 3).Select
     
    
         
         Set ligne1 = ActiveSheet.Shapes.AddLine(A, AA, B, BB)   ' je voudrais que ça tracer une ligne de coordonnées (A;AA) jusqu'à (B;BB)
    ligne1.Line.ForeColor.SchemeColor = 0
         Set ligne2 = ActiveSheet.Shapes.AddLine(B, BB, C, CC)
    ligne2.Line.ForeColor.SchemeColor = 0
        Set ligne3 = ActiveSheet.Shapes.AddLine(C, CC, D, DD)
    ligne3.Line.ForeColor.SchemeColor = 0
        Set ligne4 = ActiveSheet.Shapes.AddLine(D, DD, A, AA)
    ligne4.Line.ForeColor.SchemeColor = 0
End sub 

Le but pour moi est de tracer une rectangle avec chaque ligne de différente couleur d'où l'usage de addline plutot que addrectangle 

Par la suite je souhait procéder un peu de la même façon pour tracer des cercles avec centre et rayon depuis mon excel

Merci d'avance du coup de main

cs_Le Pivert · Answer

Bonjour,

Voici un exemple avec 2 boutons:

Option Explicit
 Private Sub CommandButton1_Click()
Dim myDocument
Set myDocument = Worksheets(1)
With myDocument.Shapes.AddLine(80, 20, 80, 200).Line 'depart left, départ top, longueur ligne, arrivée top,
    .DashStyle = msoLineSolid
    .ForeColor.RGB = RGB(255, 0, 0)
End With
With myDocument.Shapes.AddLine(80, 20, 300, 20).Line
    .DashStyle = msoLineSolid
    .ForeColor.RGB = RGB(255, 0, 0)
End With
With myDocument.Shapes.AddLine(300, 20, 300, 200).Line
    .DashStyle = msoLineSolid
    .ForeColor.RGB = RGB(255, 0, 0)
End With
With myDocument.Shapes.AddLine(80, 200, 300, 200).Line
    .DashStyle = msoLineSquareDot
    .ForeColor.RGB = RGB(255, 0, 0)
End With
With myDocument.Shapes.AddLine(80, 200, 190, 300).Line
    .DashStyle = msoLineDashDot
    .ForeColor.RGB = RGB(0, 0, 255)
End With
With myDocument.Shapes.AddLine(190, 300, 190, 200).Line
    .DashStyle = msoLineDashDotDot
    .ForeColor.RGB = RGB(255, 0, 0)
End With
With myDocument.Shapes.AddLine(190, 300, 300, 200).Line
    .DashStyle = msoLineDash
    .ForeColor.RGB = RGB(0, 0, 0)
End With
End Sub
'efface les lignes
Sub supprime()
Dim Ws As Worksheet
Dim Shp As Shape
    For Each Ws In ThisWorkbook.Worksheets
        For Each Shp In Ws.Shapes
            With Shp
               Shp.Delete
            End With
        Next Shp
    Next Ws
End Sub
Private Sub CommandButton2_Click()
supprime
End Sub
'DashStyle
'msoLineDash
'msoLineDashDot
'msoLineDashDotDot
'msoLineSolid
'msoLineSquareDot
 

Essaye de t'inspirer de cela!

Rectangle en fonction d'excel

1 réponse

Discussions similaires