Coupure de polyligne

[sean-01]

Bonjour à tous

 

Je parcours ce forum depuis quelque temps et j'y ai trouvé beaucoup de réponses à mes questions.

Mais voila j'ai un problème. Je souhaiterais pouvoir couper une polyligne en un point donné

(en VB ou VBA)

j'ai trouvé un debut de réponse sur le fil suivant

Accueil du Forum > Suggestions de développements > coupure de polyligne a une certaine distance

cf lien suivant : http:// http://cadxp.cadmag.info/sujetXForum-24936.htm

 

 
;; cptg coupure pour Thierry Garré
(defun c:cptg (/ o p1 a l p2)
(setq o (entsel "\n Coupure selectionnez l'objet: "))
(redraw (car o) 3)
(setq p1 (getpoint "\n 1er point de coupure :")
         a (getangle  p1 "\n orientation coupure :")
         l (getdist "\n longueur de la coupure :")
         p2 (polar p1 a l))  
(command "_break" o "_f" "_none" p1 "_none" p2)
)

 

Je transforme la commande lisp suivante

(command "_break" o "_f" "_none" p1 "_none" p2)

en commande VBA

 

ThisDrawing.SendCommand "_break " [surligneur] Selection [/surligneur]Point1 point2

 

Mais je ne sais pas quel sélection utiliser : nom de l'objet, Handle, une colection, un "SelectionSet" ou autre?

J'ai essayé diverses solutions et aucune ne fonctionne.

Merci pour votre aide.

NB : Si j'utilise VBA c'est que j'avais commencé à programmer sous EXCEL.

 

Question qui me parait complémentaire.

http:// http://cadxp.cadmag.info/sujetXForum-27417.htm

 

[sean-01]

Suite à ma demande j'ai cherché, cherché, ....

 

et trouvé

:)

Voici un code Succinct il ne reprend pas les fonctionnalités de l'original mais c'est pour l'exemple

 

 Sub cptg()
   Set ss = ThisDrawing.PickfirstSelectionSet
   ss.Clear
'selectionne un premier point 
   fpt = ThisDrawing.Utility.GetPoint(, "Pick first point")
   ss.Select acSelectionSetCrossing, fpt, fpt
'selectionne le second point 
  spt = ThisDrawing.Utility.GetPoint(, "Pick second point")
'recupére Handle de l'entité

   strh = ss.Item(0).Handle
'Moulinette qui remplace les point par des virgules que je sais pas pourquoi
   strp1 = Replace(CStr(fpt(0)), ",", ".") & "," & _
            Replace(CStr(fpt(1)), ",", ".") & "," & _
            Replace(CStr(fpt(2)), ",", ".")
   strp2 = Replace(CStr(spt(0)), ",", ".") & "," & _
            Replace(CStr(spt(1)), ",", ".") & "," & _
            Replace(CStr(spt(2)), ",", ".")
'commande Break qui va bien
   ThisDrawing.SendCommand "_BREAK " & _
           "(handent " & Chr(34) & strh & Chr(34) & ")" & _
           vbCr & strp1 & vbCr & strp2 & vbCr
'pour info Handent donne l'ObjectID de l'entité
End Sub

'les commentaires désobligeant sont de mon fait

:casstet:

Voici l'original

http:// http://forums.augi.com/showthread.php?t=58553

 

[surligneur] Aide-toi et le ciel t'aidera[/surligneur]

 

[Edité le 21/4/2010 par sean-01]

[sean-01]

Bonjour

Voici la suite de mes recherches, je les mets à disposition de chacun, pour vérification, modification et correction éventuelles, et transfo en VB.net

 

Inspiré des lispeurs, Programme QBRICK et autres

 

A +

 

Option Explicit

Sub coupe_entité()
'----- Codé le 26/04/10 par J-A NAVECTH -----

'Ce programme à pour but de trouver les intersections entre différentes polylignes 3d,
'et de les scinder aux points d'intersections
'Il ne fonctionne pas pour les lignes (bug quelque part ?),ni pour les polyligne 2d
'recherche_extremite_polyline() non codé

'
'
'
   Dim ssetObj As AcadSelectionSet
   Dim compte_ssetobj As Integer
   Dim elem
   Dim tempObj1(0) As AcadObject
   Dim elem2
   Dim tempObj2(0) As AcadObject
   Dim intersection
   Dim Incr2 As Integer
   Dim point_d_insertion(2) As Double
   Dim point_depart2(2) As Double
   Dim point_arrivée2(2) As Double
   Dim objretour(0) As AcadObject
'selection des objets qui s'entrecoupent
test_selection:
   On Error Resume Next
   Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
   If Err Then
       Err.Clear
       ThisDrawing.SelectionSets("SSET").Delete
       GoTo test_selection
   End If
  ssetObj.SelectOnScreen
'je ne fais pas de test de validité des objets
reinitialise_boucle:
   compte_ssetobj = ssetObj.Count
   For Each elem In ssetObj
       Set tempObj1(0) = elem
       For Each elem2 In ssetObj
           If elem.Handle <> elem2.Handle Then
               Set tempObj2(0) = elem2
               intersection = tempObj2(0).IntersectWith(tempObj1(0), acExtendNone)
's'il existe une intersection au moins entre les deux elements
' Retrouve les coordonnées des intersections

               If UBound(intersection) > 0 Then
                   For Incr2 = 0 To (UBound(intersection) - 2) / 3
                       point_d_insertion(0) = intersection(Incr2 * 3)
                       point_d_insertion(1) = intersection(Incr2 * 3 + 1)
                       point_d_insertion(2) = intersection(Incr2 * 3 + 2)
                       recherche_extremite tempObj2(0), point_depart2, point_arrivée2
                       
                       If distance_entre_points(point_d_insertion, point_depart2) > 0.000001 And _
                          distance_entre_points(point_d_insertion, point_arrivée2) > 0.000001 Then
'Verifie que l'intersection ne se trouve pas sur une extrèmité de l'élément puis le coupe en deux
                           ssetObj.RemoveItems tempObj2
'Enlève l'élément de la sélection
'Car lors de la coupe l'élément est supprimé mais existe encore dans la sélection ???
                           If CoupeObjetAuPoint(tempObj2(0), point_d_insertion, objretour(0)) Then
'ajoute les éléments créé à la sélection
                               ssetObj.AddItems objretour
                               ssetObj.AddItems tempObj2
                               GoTo reinitialise_boucle
                           Else
                               Debug.Assert 0
'Si la coupe n'a pas eu lieu remet l'élément dans la sélection
                               ssetObj.AddItems tempObj2
                           End If
                       End If
                   Next
               End If
           End If
       Next
   Next
End Sub
Function CoupeObjetAuPoint(Object, pointObj, obj_retour)

Dim nombre_d_objet As Integer
Dim strh As String
Dim strp1 As String

   CoupeObjetAuPoint = False
   nombre_d_objet = ThisDrawing.ModelSpace.Count
   ThisDrawing.SetVariable "CMDECHO", 0
   strh = Object.Handle
   strp1 = Replace(CStr(pointObj(0)), ",", ".") & "," & _
            Replace(CStr(pointObj(1)), ",", ".") & "," & _
            Replace(CStr(pointObj(2)), ",", ".")
   ThisDrawing.SendCommand "_BREAK " & _
           "(handent " & Chr(34) & strh & Chr(34) & ")" & _
           vbCr & strp1 & vbCr & strp1 & vbCr
            ThisDrawing.SetVariable "CMDECHO", 1
       If nombre_d_objet = ThisDrawing.ModelSpace.Count - 1 Then
           Set Object = ThisDrawing.ModelSpace(nombre_d_objet - 1)
           Set obj_retour = ThisDrawing.ModelSpace(nombre_d_objet)
           CoupeObjetAuPoint = True
       ElseIf nombre_d_objet = ThisDrawing.ModelSpace.Count Then
           Debug.Assert 0
       Else
           CoupeObjetAuPoint = False
       End If
End Function
Private Function recherche_extremite(objretour, point_depart, pointarrivée)
   If objretour.ObjectName = "AcDbPolyline" Then
           recherche_extremite = recherche_extremite_polyline(objretour, point_depart, pointarrivée)
   ElseIf objretour.ObjectName = "AcDbLine" Then
           recherche_extremite = recherche_extremite_line(objretour, point_depart, pointarrivée)
   ElseIf objretour.ObjectName = "AcDb3dPolyline" Then
           recherche_extremite = recherche_extremite_polyline3d(objretour, point_depart, pointarrivée)
   Else: Debug.Assert 0
   End If
End Function
Private Function recherche_extremite_polyline3d(Object, point_depart, pointarrivée)
   Dim point
   Dim i As Integer
   point = Object.Coordinate(0)
   For i = 0 To 2
       point_depart(i) = point(i)
   Next
   i = (UBound(Object.Coordinates) - 2) / 3
   point = Object.Coordinate(i)
       For i = 0 To 2
       pointarrivée(i) = point(i)
   Next
End Function
Private Function recherche_extremite_polyline(objretour, point_depart, pointarrivée)
'non codé a vous de jouer
Debug.Assert 0
End Function
Private Function recherche_extremite_line(objretour, point_depart, pointarrivée)
   Dim point
   Dim i As Integer
   point = objretour.StartPoint
   For i = 0 To 2
       point_depart(i) = point(i)
   Next
   point = objretour.EndPoint
       For i = 0 To 2
       pointarrivée(i) = point(i)
   Next
End Function

Function distance_entre_points(coord1, coord2) As Double
Dim i As Integer
For i = 0 To UBound(coord1)
distance_entre_points = distance_entre_points + (coord1(i) - coord2(i)) ^ 2
Next
distance_entre_points = distance_entre_points ^ 0.5
End Function