Rectangle en fonction d'excel

MRO -
cs_Le Pivert Messages postés 7904 Date d'inscription Statut Contributeur Dernière intervention - 1 nov. 2017 à 18:13

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

Afficher la suite

A voir également:

Rectangle en fonction d'excel
Fonction si et excel - Guide
Liste déroulante excel - Guide
Mise en forme conditionnelle excel - Guide
Word et excel gratuit - Guide
Fonction moyenne excel - Guide

1 réponse

Réponse 1 / 1

cs_Le Pivert Messages postés 7904 Date d'inscription Statut Contributeur Dernière intervention 729

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!

Discussions similaires

arriere plan

Remplir une cellule (texte) en fonction d'une autre (texte).

Votre réponse

Discussions similaires