Routine pour créer une polyligne à partir de points créés avec la fonction Mesurer

Sami2601 · le 6 décembre 2023

Bonjour tout le monde,

Je crée des points avec un intervalle de distance avec la fonction Mesurer sur ma polyligne, puis j'utilise ces points pour créer une nouvelle polyligne et ensuis je rajoute les poins de début et de fin de ma polyligne originale.

J'essaie de créer une fonction en Lisp qui me permet d'automatiser ce processus, mais je n'ai pas beaucoup d'expérience en Lisp et je n'y arrive toujours pas pour l'instant.

Je serais ravi si quelqu'un pouvait m'aider 🙂

Merci

Fraid · le 6 décembre 2023

Bonjour,

Je n'arrive pas à comprendre ce que tu fait.

Il y a 1 heure, Sami2601 a dit :

j'utilise ces points pour créer une nouvelle polyligne

Comment? En partant de chaque points? Pour aller ou?

Fraid · le 6 décembre 2023

a moins que se soit une copie de la premiere avec les sommets au droits des points?

Olivier Eckmann · le 6 décembre 2023

Le mieux c'est de reconstruire complètement la liste des points

Transforme ta polyligne en objet ActiveX avec

(vlax-ename->vla-object ...

Tu auras alors la longueur de ta polyligne avec

(vla-get-length ...

Ensuite tu crées un compteur depuis 0 jusqu'à la longueur totale par pas tel que tu souhaites (celui que tu utilises dans ta commande mesurer) et tu récupères chaque point à l'abscisse donnée avec

(vlax-curve-getPointAtDist ...

Tu insères le dernier point si pas déjà dans la liste et tu passes cette liste à ta fonction de création de polyligne.

rebcao · le 7 décembre 2023

Bonjour,

Et par hasard, tu veux peut être Numéroter automatiquement ces POINTS ?

Christian

Sami2601 · le 7 décembre 2023

Bonjour tous le monde,

Désolé si je me suis mal exprimé. Ce que je fait c'est créer les points sur ma polyligne d'origine avec _Measure, puis j'utilise ces nouveaux points pour créer ma nouvelle polyligne comme sur l'image.

Olivier Eckmann · le 7 décembre 2023

Le 06/12/2023 à 09:21, Sami2601 a dit :

Je serais ravi si quelqu'un pouvait m'aider

Tu cherches de l'aide pour écrire toi même le Lisp, ou bien tu veux un Lisp tout fait qui fait le boulot?

Olivier

Fraid · le 7 décembre 2023

Un exemple de lisp, il faut dire que ce n'est pas un exercice de nouveau débutant.

; ANSI-Windows 1252
; Autolisp
;| 
    segpol.lsp, 
    Segmente une polyligne selon une distance.

    Testé sur Windows 10 et Autocad 2015
    No copyright: (!) 2023 by Frédéric Coulon.
    No license: Do with it what you want.
|;
; Chargement des fonctions VLA/Activex.
(vl-load-com)
; getpt3dpol, récupère la liste des points d'une polyligne 2D ou 3D
(defun getpt3dpol (ent / n pts)
    (setq n (1+ (fix (vlax-curve-getEndParam ent))))
    (repeat n
        (setq pts (cons (vlax-curve-getPointAtParam ent (setq n (1- n))) pts)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:segpol ( / acdc clay ce objnam flagscu pol lptpol long pts cpt lpt lpts)
    (setq acdc (vla-get-activedocument (vlax-get-acad-object))
          clay (getvar 'clayer))
    ; Point de retour      
    (vla-startundomark acdc)
    (setq ce (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    ; Controle du SCU
    (if (= (getvar "worlducs") 0)(setq flagscu (vl-cmdf "_ucs" "")))
    ; Séléction de la polyligne.
    (while (not (wcmatch (setq objnam (cdr (assoc 0 (entget (setq pol (car (entsel "\nSéléctionnez une polyligne"))))))) "*POLYLINE")))
    (if pol 
        (progn
                ; Liste des points de la polyligne.
            (setq lptpol (getpt3dpol pol)
                  long (getint "\nLongueur des segments: "))
                ; Création du calque TMP.
            (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list layers "TMP" )))
                (vla-add (vla-get-layers acdc) "TMP"))
            ; les points de la commande MESURER sont placés dans le calque TMP.
            (setvar 'clayer "TMP")
            (command "_measure" pol long)
            (setvar 'clayer clay)
                ; Séléction des points.
            (if (setq pts (ssget "_x" (list (cons 0 "point")(cons 8 "TMP"))))
                (progn
                    (setq cpt 0)
                    (while (setq point (ssname pts cpt))
                        ; Liste des coordonnnées des points.
                        (setq lpt (cons (cdr (assoc 10 (entget point))) lpt)
                              cpt (1+ cpt)))
                        ; Rajout des extrémités de la polyligne.
                    (setq lpt (cons (car lptpol) lpt)
                          lpt (reverse (cons (last lptpol) (reverse lpt))))
                        ; Formatage de la liste pour vla-AddLightWeightPolyline ou vla-Add3DPoly.
                    (if (= objnam "POLYLINE")
                        (progn
                            (setq lpt (apply 'append (mapcar '(lambda (x)(list (car x) (cadr x) (caddr x))) lpt))
                                  lpts (vlax-make-safearray vlax-vbDouble (cons 0 (- (length lpt) 1))))
                            (vlax-safearray-fill lpts lpt)
                            ; Dessin de la polyligne 3D
                            (vla-Add3DPoly (vla-get-ModelSpace acdc) lpts)
                        )
                        (progn
                            (setq lpt (apply 'append (mapcar '(lambda (x)(list (car x) (cadr x))) lpt))
                                  lpts (vlax-make-safearray vlax-vbDouble (cons 0 (- (length lpt) 1))))
                            (vlax-safearray-fill lpts lpt)
                            ; Dessin de la polyligne
                            (vla-AddLightWeightPolyline (vla-get-ModelSpace acdc) lpts)
                        )
                    )
                    ; Efface les points et la polyligne.
                    (initget 1 "Oui Non")
                    (if (eq (getkword "\nSupprimer la polyligne originale? [Oui/Non] <Oui> : ") "Oui")
                        (command "_erase" pts pol "")
                        (command "_erase" pts ""))
                )
                (princ "\nAbandon, vérifiez la longueur des segments.")
            )          
        )
        (princ "\nAbandon.")
    )
    ; Restauration du SCU.
    (if flagscu (command "_ucs" "p"))
    ; Restauration echo
    (setvar 'cmdecho ce)
     ; Fin du UndoMark.
    (if (= 8 (logand 8 (getvar 'UNDOCTL)))(vla-EndUndoMark acdc))
    (princ)
)

Il faut taper segpol, puis choisir sa polyligne et donner la longueur des segments.

Modifié le 10 décembre 2023 par Fraid
Prise en charge des polylignes 3D

Sami2601 · le 7 décembre 2023

il y a 58 minutes, Fraid a dit :

Un exemple de lisp, il faut dire que ce n'est pas un exercice de nouveau débutant.

Pas le temps de commenter.

(vl-load-com)
(defun butLast (liste) (reverse (cdr (reverse liste))))
(defun c:segpol ( / acdc clay pol ent lptpol long pts cpt lpt lpts)
    (setq acdc (vla-get-activedocument (vlax-get-acad-object))
          clay (getvar 'clayer)
    )
    (while (not (eq (cdr (assoc 0 (setq ent (entget (setq pol (car (entsel "\nSéléctionnez une polyligne"))))))) "LWPOLYLINE")))
    (if ent 
        (progn
            (setq lptpol (append (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) ent)) lptpol)
                  long (getint "\nLongueur des segments: "))
            
            (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list layers "TMP" )))
                (vla-add (vla-get-layers acdc) "TMP"))
            (setvar 'clayer "TMP")
            (command "_measure" pol long)
            (setvar 'clayer clay)
            (if (setq pts (ssget "_x" (list (cons 0 "point")(cons 8 "TMP"))))
                (progn
                    (setq cpt 0)
                    (while (setq point (ssname pts cpt))
                        (setq lpt (cons (butlast (cdr (assoc 10 (entget point)))) lpt)
                              cpt (1+ cpt)))
                    (setq lpt (cons (car lptpol) lpt)
                          lpt (reverse (cons (last lptpol) (reverse lpt)))
                          lpt (apply 'append (mapcar '(lambda (x)(list (car x) (cadr x))) lpt))
                          lpts (vlax-make-safearray vlax-vbDouble (cons 0 (- (length lpt) 1)))
                    )
                    (vlax-safearray-fill lpts lpt)
                    (vla-AddLightWeightPolyline (vla-get-ModelSpace acdc) lpts)
                )
                (princ "\nAbandon, vérifiez la longueur des segments.")
            )          
        )
        (princ "\nAbandon.")
    )
    (princ)
)

Il faut taper segpol, puis choisir sa polyligne et donner la longueur des segments.

C'est parfait c'est exactement ce que je cherchais ! Merci beaucoup !

Fraid · le 7 décembre 2023

Il y a 2 heures, Sami2601 a dit :

Merci beaucoup !

De rien,

j'ai modifié le code pour qu'il supprime les points à la fin.

Sinon, j'ai trouvé pratique de créer un calque pour sélectionner facilement les points.

Il sautera à la prochaine purge.

Veux tu supprimer aussi la polyligne originale?

Sami2601 · le 8 décembre 2023

Il y a 18 heures, Fraid a dit :

De rien,

j'ai modifié le code pour qu'il supprime les points à la fin.

Sinon, j'ai trouvé pratique de créer un calque pour sélectionner facilement les points.

Il sautera à la prochaine purge.

Veux tu supprimer aussi la polyligne originale?

Bonjour Fraid,

Je viens de voir ton message, hier j'ai fait la même chose, j'ai commenté ton code en cherchant sur internet, c'est bien pensé la méthode de les stocker sur un calque temporaire je galérais à trouver comment stocker seulement les points créés! Puis j'ai rajouté une ligne pour supprimer les points à la fin :

;; Supprime les points de la couche temporaire

(command "_erase" pts "")

)

;; Affiche un message si la sélection de points a échoué

(princ "\nAbandon, vérifiez la longueur des segments.")

j'ai aussi essayé de rajouter la sélection d'une polyligne 3d avec "POLYLINE", et tracer une polyligne 3d avec :

(vla-Add3Dpoly (vla-get-ModelSpace acdc) lpts)

pour ne pas perdre le Z des sommets mais ca ne marche pas bien.

Je ne sais pas s'il faut changer d'autre paramètres pour cela.

Pour supprimer la polyligne original si ce n'est pas compliqué d'avoir la possibilité à la fin de choisir avec O/N ca serait super:)

Fraid · le 9 décembre 2023

Le 08/12/2023 à 11:23, Sami2601 a dit :

choisir avec O/N

Yop, c'est fait, j'ai rajoute

- un undomark qui permet de revenir en arrière avec un seul ctrl+Z

- un controle du SCU

- la question pour effacer la polyligne

Pour la 3D, il faut revoir tout le code,

Olivier Eckmann · le 9 décembre 2023

Bonjour,

Ci-joint le code pour choisir poly2D ou 3D (le code de dessin des poly2D et 3D a été repris depuis le site DA-Code de Didier Aveline) :

; Didier Aveline
; https://www.da-code.fr/poly-07/
(defun da:DessPoly2D (listesommets z closed)
  ; dessin de polyligne 2D depuis liste de sommmets
  (entmake
    (append
      (list
        '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbPolyline")
        (if z (cons 38 z))
        (cons 90 (length listesommets))
	(if closed (cons 70 1) (cons 70 0))
        ;;'(70 . 0)
      )
      (mapcar '(lambda (p) (cons 10 p)) listesommets)
    ) 
  ) ;_ Fin de entmake
) ; fin de defun da:DessPoly2D

(defun da:DessPoly3D (ptlist closed / pt)
  ; dessin de polyligne 3D depuis liste de sommmets
  
  (entmake (list '(0 . "POLYLINE")
		 '(100 . "AcDbEntity")
		 '(100 . "AcDb3dPolyline")
		 (if closed (cons 70 9) (cons 70 8))
	   )
  )
  (repeat (length ptlist)
    (setq pt     (car ptlist)
          ptlist (cdr ptlist)
          )
    (entmake (list
               '(0 . "VERTEX")
               '(100 . "AcDb3dPolylineVertex")
               (cons 10 pt)
               '(70 . 32)
               )
             )
    ) ;_ repeat
  (entmake '((0 . "SEQEND")))
) ; fin de defun da:DessPoly3D

;Olivier Eckmann
;https://cadxp.com/topic/60969-routine-pour-créer-une-polyligne-à-partir-de-points-créés-avec-la-fonction-mesurer/
(defun C:Poly2Poly ( / dPas sTypePoly sSupprPoly oPoly oPolyDxf oPolyVla PTF dAbsc PT lsPts)
  (if (setq dPas (getreal "\nDistance entre sommets:"))
    (progn
      (initget "2D 3D")
      (setq sTypePoly (getkword "\nGénérer une polyligne [2D/3D] <3D> : "))
      (if (not sTypePoly)
	(setq sTypePoly "3D")
      )
      (initget "Oui Non")
      (setq sSupprPoly (getkword "\nSupprimer la polyligne initiale [Oui/Non] <Oui> : "))
      (if (not sSupprPoly)
	(setq sSupprPoly "Oui")
      )
      (while (and (setq oPoly (car (entsel "\nSélectionner une polyligne : ")))
		  (setq oPolyDxf (entget oPoly))
		  (member (cdr (assoc 0 oPolyDxf)) (list "POLYLINE" "LWPOLYLINE"))
	     )
	(setq oPolyVla (vlax-ename->vla-object oPoly))
	(setq dLength (vla-get-length oPolyVla))
	(setq bClosed (eq (vla-get-Closed oPolyVla) :vlax-true))
	(setq PTF (vlax-curve-getEndPoint oPolyVla))
	(setq dAbsc 0.0
	      lsPts nil)
	(while (<= dAbsc dLength)
	  (setq PT (vlax-curve-getPointAtDist oPolyVla dAbsc))
	  (setq lsPts (append lsPts (list PT)))
	  (setq dAbsc (+ dAbsc dPas))
	)
	; Ajout du dernier point si pas déjà présent en fin de liste
	(if (and (not bClosed) (> (distance (last lsPts) PTF) 0.001))
	  (setq lsPts (append lsPts (list PTF)))
	)
	; dessin de la poly 2D ou 3D
      	(if (= sTypePoly "2D")
	  (da:DessPoly2D lsPts (caddr (car lsPts)) bClosed)
	  (da:DessPoly3D lsPts                     bClosed)
        )
	; Suppression de la poly de base si demandé
        (if (= sSupprPoly "Oui")
	  (entdel oPoly)
        )
      )
    )
  )
)

Poly2Poly.lsp

Modifié le 10 décembre 2023 par Olivier Eckmann
Modification du code de test d'ajouter du dernier point que si la polyligne n'est pas fermée

Fraid · le 10 décembre 2023

Le 08/12/2023 à 11:23, Sami2601 a dit :

rajouter la sélection d'une polyligne 3d

J'ai modifié le code, il prend en charge les polylignes 3D.

Tu as en plus le code d'Oliviers, cela te permet de voir une autre façon.

Il y en à plein ...

je ne pense pas avoir envisager tous les bugs possibles..

n'hésite pas à le dire, cela profitera à la communauté.

En tout cas, bienvenus et bon courage

Sami2601 · le 12 décembre 2023

Merci à beaucoup à vous pour votre temps, c'est parfait !

Sami2601 · le 30 janvier

Le 09/12/2023 à 20:39, Olivier Eckmann a dit :

Bonjour,

Ci-joint le code pour choisir poly2D ou 3D (le code de dessin des poly2D et 3D a été repris depuis le site DA-Code de Didier Aveline) :

Poly2Poly.lsp 2.81 Ko · 1 téléchargement

Bonjour 🙂

J'aurais besoin une nouvelle fois de votre aide. j'ai essayé de rajouter la possibilité de dessiner une Spline a partir des nouveaux sommet mais sans succès.

Je vous remercie d'avance pour votre temps !

; Didier Aveline
; https://www.da-code.fr/poly-07/
(defun da:DessPoly2D (listesommets z closed)
  ; dessin de polyligne 2D depuis liste de sommmets
  (entmake
    (append
      (list
        '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbPolyline")
        (if z (cons 38 z))
        (cons 90 (length listesommets))
	(if closed (cons 70 1) (cons 70 0))
        ;;'(70 . 0)
      )
      (mapcar '(lambda (p) (cons 10 p)) listesommets)
    ) 
  ) ;_ Fin de entmake
) ; fin de defun da:DessPoly2D

(defun da:DessPoly3D (ptlist closed / pt)
  ; dessin de polyligne 3D depuis liste de sommmets
  
  (entmake (list '(0 . "POLYLINE")
		 '(100 . "AcDbEntity")
		 '(100 . "AcDb3dPolyline")
		 (if closed (cons 70 9) (cons 70 8))
	   )
  )
  (repeat (length ptlist)
    (setq pt     (car ptlist)
          ptlist (cdr ptlist)
          )
    (entmake (list
               '(0 . "VERTEX")
               '(100 . "AcDb3dPolylineVertex")
               (cons 10 pt)
               '(70 . 32)
               )
             )
    ) ;_ repeat
  (entmake '((0 . "SEQEND")))
) ; fin de defun da:DessPoly3D

(defun da:DessSpline (ptlist / pt)
  ; dessin de spline depuis liste de sommmets
  
  (entmake (list '(0 . "SPLINE")
		 '(100 . "AcDbEntity")
		 '(100 . "AcDbSpline")
	   )
  )
  (repeat (length ptlist)
    (setq pt     (car ptlist)
          ptlist (cdr ptlist)
          )
    (entmake (list
               '(0 . "VERTEX")
               '(100 . "AcDbSplineVertex")
               (cons 10 pt)
               '(70 . 32)
               )
             )
    ) ;_ repeat
  (entmake '((0 . "SEQEND")))
) ; fin de defun da:DessSpline

;Olivier Eckmann
;https://cadxp.com/topic/60969-routine-pour-créer-une-polyligne-à-partir-de-points-créés-avec-la-fonction-mesurer/
(defun C:Poly2Poly ( / dPas sTypePoly sSupprPoly oCurve oCurveDxf oCurveVla PTF dAbsc PT lsPts)
  (if (setq dPas (getreal "\nDistance entre les sommets:"))
    (progn
      (initget "2D 3D Spline")
      (setq sTypePoly (getkword "\nGénérer une polyligne [2D/3D/Spline] <3D>: "))
      (if (not sTypePoly)
        (setq sTypePoly "3D")
      )
      ;Choix de suppression de polyligne originale
      (initget "Oui Non")
      (setq sSupprPoly (getkword "\nSupprimer l'originale [Oui/Non] <Oui> : "))
      (if (not sSupprPoly)
        (setq sSupprPoly "Oui")
      )
      (while (and (setq oCurve (car (entsel "\nSélectionnez une polyligne ou une spline: ")))
                  (setq oCurveDxf (entget oCurve))
                  (or (member (cdr (assoc 0 oCurveDxf)) '("POLYLINE" "LWPOLYLINE" "SPLINE"))
                      (progn
                        (princ "\nL'entité sélectionnée n'est ni une polyligne ni une spline. Veuillez sélectionner une polyligne ou une spline.")
                        nil
                      )
                  )
             )
        (setq oCurveVla (vlax-ename->vla-object oCurve))
        (setq dLength (if (eq (cdr (assoc 0 oCurveDxf)) "SPLINE")
                          (vlax-curve-getEndParam oCurveVla)
                        (vla-get-Length oCurveVla)
                      )
        )
        (setq bClosed (or (eq (vla-get-Closed oCurveVla) :vlax-true) (eq (cdr (assoc 0 oCurveDxf)) "CLOSED")))
        (setq PTF (vlax-curve-getEndPoint oCurveVla))
        (setq dAbsc 0.0
              lsPts nil)
        (while (<= dAbsc dLength)
          (setq PT (vlax-curve-getPointAtDist oCurveVla dAbsc))
          (setq lsPts (append lsPts (list PT)))
          (setq dAbsc (+ dAbsc dPas))
        )
        ; Add the last point if not already present at the end of the list
        (if (and (not bClosed) (> (distance (last lsPts) PTF) 0.001))
          (setq lsPts (append lsPts (list PTF)))
        )
        ; Draw the 2D or 3D polyline or spline
        (cond
          ((= sTypePoly "2D") (da:DessPoly2D lsPts (caddr (car lsPts)) bClosed))
          ((= sTypePoly "3D") (da:DessPoly3D lsPts bClosed))
          ((= sTypePoly "Spline") (da:DessSpline lsPts))
        )
        ; Delete the original curve if requested
        (if (= sSupprPoly "Oui")
          (entdel oCurve)
        )
      )
    )
  )
)

bonuscad · le 30 janvier

Bonjour,

Aurais tu plus de facilité avec un code plus simple?

Par exemple!

(defun c:test ( / js ent l_pt closed lg_seg typ)
  (while (null (setq js (ssget "_+.:E:S" '((0 . "*POLYLINE") (-4 . "<NOT") (-4 . "&") (70 . 112) (-4 . "NOT>"))))))
  (setq
    ent (ssname js 0)
    l_pt (list (vlax-curve-getEndPoint ent))
    closed (vlax-curve-isClosed ent)
  )
  (initget 91)
  (setq lg_seg (getdist "\nLongueur des segments: "))
  (command "_.measure" ent lg_seg)
  (while
    (and
      (= (cdr (assoc 0 (entget (entlast)))) "POINT")
      (not (equal (entlast) ent))
    )
    (setq l_pt (cons (cdr (assoc 10 (entget (entlast)))) l_pt))
    (entdel (entlast))
  )
  (setq l_pt (cons (vlax-curve-getStartPoint ent) l_pt))
  (cond
    (l_pt
      (initget "2D 3D Spline")
      (setq typ (getkword "\nDessiner une polyligne [2D/3D/Spline]?: "))
      (cond
        ((eq typ "2D") (command "_.pline"))
        ((eq typ "3D") (command "_.3dpoly"))
        ((eq typ "Spline") (command "_.spline"))
      )
      (foreach n l_pt (command "_none" n))
      (if (eq typ "Spline")
        (if closed (command "_close" "") (command "" "" ""))
        (if closed (command "_close") (command ""))
      )
    )
  )
  (initget "Oui Non")
  (if (eq (getkword "\nEffacer l'entité source? [Oui/Non] <N>: ") "Oui")
    (entdel ent)
  )
  (prin1)
)

Sami2601 · le 22 mars

Bonjour,

oui c'est parfait merci !!

Connexion

Routine pour créer une polyligne à partir de points créés avec la fonction Mesurer

Messages recommandés

Sami2601

Fraid

Fraid

Olivier Eckmann

rebcao

Sami2601

Olivier Eckmann

Fraid

Sami2601

Fraid

Sami2601

Fraid

Olivier Eckmann

Fraid

Sami2601

Sami2601

bonuscad

Sami2601

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante