Récupérer les Coordonnées des deux extrémités de plusieurs lignes

[jfcantin197733]

Bonjour

 

J'ai fait un post il y a de cela quelques jours mais je n'ai eu aucune réponse.. alors vois une partie du code.... qui ne fonctionne pas. Mon code doit arriver à connaitre les deux extrémités de plusieurs segments

 

En d'autres mots, si un utilisateur trace une ligne droite qui contient 3 segments. Je dois récupérer les deux extrémité de cette droite qui contient 3 segments. Si par exemple le segments est tracé à l'horizonatle, je veux récupérer la coordonnée extreme Ouest et la coordonnée à l'extrémité Est.

 

Dans mon code je sélectionne les trois lignes et je mets dans un tableau les coordonnées de chaque lignes sélectionnées.

 

 For Each AcadObj In ssetobj
       Select Case AcadObj.ObjectName
       Case "AcDbLine"    'Ligne
            If Compteur = 0 Then
               ReDim Tableau_Somme_Ligne(Compteur)
           Else
               ReDim Preserve Tableau_Somme_Ligne(Compteur)
           End If
           
           varStart = AcadObj.StartPoint
           varEnd = AcadObj.EndPoint
           Tableau_Somme_Ligne(Compteur) = varStart(0) & ";" & varStart(1) & "-" & varEnd(0) & ";" & varEnd(1)
           
           Somme_Lignes = AcadObj.Length + Somme_Lignes
           Compteur = Compteur + 1

 

 

Ensuite j'avais pensé de "Spliter" mon tableau afin de récurérer la premiere coordonnée du tableau (qui selon moi devrait etre la premiere ligne sélectionne) et de prendre la derniere ligne de mon tableau pour la coordonnées de la derniere ligne sélectionnée.

 

         Dim Tableau_Split() As String
       Dim Tableau_Split2() As String
       
       Tableau_Split = Split(Tableau_Somme_Ligne(0), "-")
       MsgBox (Tableau_Split(0) & "   " & Tableau_Split(1))
       Tableau_Split2 = Split(Tableau_Split(0), ";")
       dblXs = Tableau_Split2(0)
       dblYs = Tableau_Split2(1)
       Tableau_Split = Split(Tableau_Somme_Ligne(Compteur - 1))

 

Le problème, lors de la sélection des lignes, il mélange l'orde de la sélection.

La premiere ligne qu'il met dans le tableau est la ligne au centre. Cette ligne a été la deuxieme ligne que j'ai sélectionné.

 

 

Comment est-il possible d'arriver à mes fins ?

 

Mon but est de connaitre le centre de ces trois lignes.

 

 

merci de votre aide

 

 

[winfield]

Slt

 

Mon but est de connaitre le centre de ces trois lignes

Fais attention, une ligne peut cacher une polyligne ! Ceci sans compter qu'une ligne peut avoir le même point de départ ET d'arrivée etc... Si c'est une poly, il peut y a avoir encore plus de difficultés.

 

Ton tableau ne fait que t'apporter des soucis supplémentaire dans ton contexte, enfin, ça dépend du pourquoi de la nécessité de connaitre le mlieu de chaque segment et ce que tu veux faire de ces informations.

 

Je te laisse un exemple pour régler ton soucis, à modifier par rapport à tes besoins.

 

 

 Sub PtMilieu()
  
   Dim PtMid As Variant
   Dim ObjSelection As AcadSelectionSet
   Dim StrSelection As String
   Dim ObjCircle As AcadCircle
   Dim ObjTxt As AcadText
   
   StrSelection = "SelectMid"
   
   On Error Resume Next
   
   Set ObjSelection = ThisDrawing.SelectionSets(StrSelection)
   If Err Then
       Err.Clear
       Set ObjSelection = ThisDrawing.SelectionSets.Add(StrSelection)
   End If
   ObjSelection.Clear
   
   ObjSelection.SelectOnScreen
   
   For I = 0 To ObjSelection.Count - 1
       PtMid = ThisDrawing.Utility.PolarPoint(ObjSelection(I).startPoint, ObjSelection(I).Angle, ObjSelection(I).length / 2)
       Set ObjCircle = ThisDrawing.ModelSpace.AddCircle(PtMid, ObjSelection(I).length / 20)
   Next
   
End Sub 

[jfcantin197733]

Bonjour winfield

 

Merci pour le code...

 

Je vais fouiiller un peu mais ce que je cherche est le centre des 3 lignes enssemble. Uniquement un centre.

 

Je veux pas le centre des 3 lignes mais de la somme des 3 segments et ainsi trouver le centre.

 

En d'autres mots, j'ai trois lignes droites qui se touchent et je veux trouver le centre de ce segments, comme si ces 3 lignes formeraient qu'une seule ligne.

 

C'est cela qui m'embête...

 

Merci de ton aide

[jfcantin197733]

J'ai trouvé... en utilisant ton code....

 

Merci mille fois c'est tres apprécié

 

 Sub PtMilieu()
  
   Dim PtMid As Variant
   Dim ObjSelection As AcadSelectionSet
   Dim StrSelection As String
   Dim ObjCircle As AcadCircle
   Dim ObjTxt As AcadText
   
   Dim AcadObj As Variant
   
   StrSelection = "SelectMid"
   
   On Error Resume Next
   
   Set ObjSelection = ThisDrawing.SelectionSets(StrSelection)
   If Err Then
       Err.Clear
       Set ObjSelection = ThisDrawing.SelectionSets.Add(StrSelection)
   End If
   
    ObjSelection.Clear
   
   ObjSelection.SelectOnScreen
   
   For Each AcadObj In ObjSelection
       Select Case AcadObj.ObjectName
       Case "AcDbLine"    'Ligne
           Somme_Lignes = AcadObj.Length + Somme_Lignes
       Case "AcDbArc"    'Arc
           'Code à ajouter
       End Select
   Next AcadObj
   
   Somme_Lignes = Somme_Lignes / 2

       PtMid = ThisDrawing.Utility.PolarPoint(ObjSelection(i).StartPoint, ObjSelection(i).Angle, Somme_Lignes)
       Set ObjCircle = ThisDrawing.ModelSpace.AddCircle(PtMid, ObjSelection(i).Length / 20)
  
End Sub

 

 

[winfield]

Slt

Content que t'avoir aidé

 

Pour améliorer ta routine, tu pourrais faire en sorte que ça marche peu importe le SCU ;)

Si tu ne t'interrsse qu'aux lignes et arcs, tu pourrais aussi intégrer des filtres de selections.

 

 

[jfcantin197733]

Intéressant les filtres de sélection mais... tu me perds.. je débute avec autocad..

 

Si tu peux me donne rune piste.... merci d'avance...

[winfield]

Slt

En reprenant le 1er code:

 Sub PtMilieu0()
  
   Dim PtMid As Variant
   Dim ObjSelection As AcadSelectionSet
   Dim StrSelection As String
   Dim ObjCircle As AcadCircle
   Dim ObjTxt As AcadText
       
   StrSelection = "SelectMid"
   
   On Error Resume Next
   
   Set ObjSelection = ThisDrawing.SelectionSets(StrSelection)
   If Err Then
       Err.Clear
       Set ObjSelection = ThisDrawing.SelectionSets.Add(StrSelection)
   End If
   ObjSelection.Clear
   
   Dim CodeDXF(1) As Integer
   Dim VarDXF(1) As Variant
   
   CodeDXF(0) = 0: VarDXF(0) = "LINE"
   CodeDXF(1) = 8: VarDXF(1) = "MonCalque"
   
   ObjSelection.SelectOnScreen CodeDXF, VarDXF
   
   For I = 0 To ObjSelection.Count - 1
       PtMid = ThisDrawing.Utility.PolarPoint(ObjSelection(I).StartPoint, ObjSelection(I).Angle, ObjSelection(I).Length / 2)
       Set ObjCircle = ThisDrawing.ModelSpace.AddCircle(PtMid, ObjSelection(I).Length / 20)
   Next
   
End Sub 

Cette modification du code permet de faire une fenetre de selection et ne selectionnera que les objets "Line" qui sont dans le calque "MonCalque", s'il existe bien entendu.

Tu peux insérer aussi des conditions "Si" "OU" "ET" par ex :

Toutes les lignes qui sont dans le calque "toto" ET dans le calque "Tutu" ET qui sont de couleur "Red".....

 

Tiré de l'Aide :

 

Sub Example_Select()

' This example adds members to a selection set, first by crossing and

' then by filtering for circles.

 

' Create the selection set

Dim ssetObj As AcadSelectionSet

Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")

 

 

' Add all object to the selection set that lie within a crossing of (28,17,0) and

' (-3.3, -3.6,0)

Dim mode As Integer

Dim corner1(0 To 2) As Double

Dim corner2(0 To 2) As Double

 

mode = acSelectionSetCrossing

corner1(0) = 28: corner1(1) = 17: corner1(2) = 0

corner2(0) = -3.3: corner2(1) = -3.6: corner2(2) = 0

ssetObj.Select mode, corner1, corner2

 

' Add all the Circles to the selection set that lie within the crossing of (28,17,0) and

' (-3.3, -3.6,0) by filtering from the current drawing

Dim gpCode(0) As Integer

Dim dataValue(0) As Variant

gpCode(0) = 0

dataValue(0) = "Circle"

 

Dim groupCode As Variant, dataCode As Variant

groupCode = gpCode

dataCode = dataValue

 

ssetObj.Select mode, corner1, corner2, groupCode, dataCode

 

End Sub

 

Bon courage !

[jfcantin197733]

merci beaucoup

 

c,est tres gentil...

 

Pour mon code cela ne me sera pas utile mais je garde ce code tout près car il pourra me servir un jour

 

 

merci encore