Alternating poly line trim routine.

[Jamesclark64]

I'm pretty sure what I'm about to ask is beyond the capabilities of a lisp routine but ill ask nonetheless. Would it be possible to to create a lisp routine that could break and delete the *even* segments of a polyline? for example keep the first line get rid of the second and keep the third etc.

Its a bit hard for me to explain so I've added a screenshot of what I mean.

Thanks Jay.

[marko_ribar]

It can be done via LISP...

Is this your homework, paid task, or exibition with programming experiment?

[Jamesclark64]

5 minutes ago, marko_ribar said:

It can be done via LISP...

Is this your homework, paid task, or exibition with programming experiment?

I'm a building surveyor (old school with total station) and looking to speed up my work flow on site. I'm not sure how much work is involved. How much would something like this cost me to get made?

[Steven P]

Barely an inconvenience...

 

This should work for LWpolylines, command is "OddSegments"

 

(defun c:oddsegments ( / MyPoly LastEnt Verticies acount )
  ;;SubFunctions
  (defun mAssoc ( key lst / result ) ; https://www.cadtutor.net/forum/topic/27914-massoc-implementations/
    (foreach x lst
      (if (= key (car x)) (setq result (cons (cdr x) result)) )
    )
    (reverse result)
  )
  ;;End Sub Functions

  (setq MyPoly (car (entsel "Select PolyLine: ")))      ;;Select Polyline
  (if (= (cdr (assoc 0 (entget MyPoly))) "LWPOLYLINE")  ;;Check a LWPolyLine was selected
    (progn
      (setq LastEnt (entlast))                          ;;Find the marker for the last entity created
      (setq Verticies (length (mAssoc 10 (entget MyPoly)))) ;;returns the coordinates
      (command "copy" MyPoly "" '(0 0 0) '(0 0 0) "")(entdel MyPoly) ;;copy and delete the existing line
      (command "Explode" (entlast))                     ;;explode the new line
      (setq acount 1)                                   ;;A counter
      (while (< acount verticies)                       ;;a loop if counter is less then no, of veritcies
        (setq LastEnt (entnext LastEnt))                ;;get first segment of copied polyline
        (setq acount (+ acount 1))                      ;;increment counter
        (setq LastEnt (entnext LastEnt))                ;;get next segment of copied polyline
        (if (< acount verticies)(entdel LastEnt))       ;;Delete the segment as required
        (setq acount (+ acount 1))                      ;;Increase counter
      ) ; end while                                     ;;end loop
    ) ; end progn
    (princ "PolyLine Not Selected")                     ;;if polyline wasn't selected
  ) ; end if
)

 

Edited October 31, 2023 by Steven P

[Tharwat]

4 hours ago, Jamesclark64 said:

I'm a building surveyor (old school with total station) and looking to speed up my work flow on site. I'm not sure how much work is involved. How much would something like this cost me to get made?

Give this a shot and let me know how it works for you.

You can private message me if you would like me to develop it further for you or if you appreciate the time that I invested in this program for you.

(defun c:Test (/ sel get pts 40s fnd asc)
  ;;----------------------------------------------------;;
  ;;	Author : Tharwat Al Choufi			;;
  ;; website: https://autolispprograms.wordpress.com	;;
  ;;----------------------------------------------------;;
  (and
    (princ "\nSelect polyline : ")
    (or
      (setq sel (ssget "_+.:S:E:L" '((0 . "LWPOLYLINE"))))
      (alert
        "Nothing selected or Invalid selected object or polyline resides on locked layer.!"
      )
    )
    (or (foreach itm (setq get (entget (ssname sel 0)))
          (and (= (car itm) 10)
               (setq pts (cons itm pts))
          )
        )
        t
    )
    (setq pts (reverse pts))
    (while (cdr pts)
      (and (setq 40s nil
                 fnd (member (car pts) get)
           )
           (repeat 5
             (setq 40s (cons (car fnd) 40s)
                   fnd (cdr fnd)
             )
           )
           (entmake (append '((0 . "LWPOLYLINE")
                              (100 . "AcDbEntity")
                              (100 . "AcDbPolyline")
                              (90 . 2)
                              (70 . 0)
                             )
                            (list (assoc 8 get)
                                  (cons 62
                                        (if (setq asc (assoc 62 get))
                                          (cdr asc)
                                          256
                                        )
                                  )
                                  (cons 6
                                        (if (setq asc (assoc 6 get))
                                          (cdr asc)
                                          "ByLayer"
                                        )
                                  )
                                  (cons 370
                                        (if (setq asc (assoc 370 get))
                                          (cdr asc)
                                          -1
                                        )
                                  )
                                  (car pts)
                            )
                            (cdr (reverse 40s))
                            (list (cadr pts))
                    )
           )
      )
      (setq pts (cddr pts))
    )
  )
  (entdel (ssname sel 0))
  (princ)
)

 

[BIGAL]

Another dont have time just now is just break the pline at the vertices 2-3, 4-5, 6-7 etc.

 

[exceed]

 

(defun c:evenpoly ()
  (princ "\n get polyline's even line : ")
  (@evenoddpoly 0)
)

(defun c:oddpoly ()
  (princ "\n get polyline's odd line : ")
  (@evenoddpoly 1)
)

(defun @evenoddpoly ( evenodd / ss ssl index ent entl ptlist isclosed ptlen 1pt 2pt )
  (defun LWPolybyList (lst cls) 
    (entmakex 
      (append 
        (list 
          (cons 0 "LWPOLYLINE")
          (cons 100 "AcDbEntity")
          (cons 100 "AcDbPolyline")
          (cons 90 (length lst))
          (cons 70 cls)
        )
        (mapcar (function (lambda (p) (cons 10 p))) lst)
      )
    )
  )
  ;;;Michal Puckett
  (defun cdrs (key lst / pair rtn)
    (while (setq pair (assoc key lst))
      (setq rtn (cons (cdr pair) rtn)
             lst (cdr (member pair lst))
      )
    )
    (reverse rtn)
  )

  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  (setq ssl (sslength ss))
  (setq index 0)
  (setq ss2 (ssadd))
  (repeat ssl
    (setq ent (ssname ss index))
    (setq entl (entget ent))
    (setq ptlist (cdrs 10 entl))
    (setq isclosed (cdr (assoc 70 entl)))
    (if (= isclosed 1)
      (progn 
        (setq ptlist (cons (car ptlist) (reverse ptlist)))
        (setq ptlist (reverse ptlist))
      )
    )
    (if (= evenodd 1) ;if odd selected
      (setq ptlist (cdr ptlist)) ;get rid of first vertice
    )
    (setq ptlen (length ptlist))
    (if (= (rem ptlen 2) 1)
      (setq ptlen (- ptlen 1)) ;if ptlist is odd
    )
    (setq index2 0)
    (repeat (/ ptlen 2)
      (setq 1pt (nth index2 ptlist))
      (setq 2pt (nth (+ index2 1) ptlist))
      (setq newpl (LWPolybyList (list 1pt 2pt) 0))
      (ssadd newpl ss2)
      (setq index2 (+ index2 2))
    )
    (setq index (+ index 1))
  )
  (sssetfirst nil ss2)
  (princ)
)

 

[Steven P]

And here is another that will keep the lines as polylines (width, colours, and so on should be retained)

 

 

EDITTED:

version 2 of this method - happier with it (ie. it works....), will copy the polyline for each vertex and only for that one, retaining layers, colours, widths, arcs and so on

 

(defun c:oddeven ( / MyPoly MyEnt acount tenslist removelist n)
  ;;SubFunctions
  (defun LM:RemoveNth ( n l ) ;;Refer to Lee Macs website
    (if (and l (< 0 n))
        (cons (car l) (LM:RemoveNth (1- n) (cdr l)))
        (cdr l)
    )
  )
  ;;end subfunctions

  (setq MyPoly (car (entsel "\nSelect Polyline")))   ;;Select a polyline
  (if (or (= MyPoly nil) 
          (/= (cdr (assoc 0 (entget MyPoly))) "LWPOLYLINE")
      ) ; endor                                      ;;If no polyline selected
    (princ "\nPolyline not selected")                ;;error message 'no polyline'
    (progn                                           ;;If Polyline
      (setq MyEnt (entget MyPoly))                   ;;Get line definition entity codes
      (setq acount 0)                                ;;A counter
      (setq tenslist (list))                         ;;Blank list for the coordinates
      (while (< acount (length MyEnt))               ;;Get list of coordinate positions
        (if (= (car (nth acount MyEnt)) 10)          ;;Loop through list, if assoc code 10 record its position
          (setq tenslist (append tenslist (list acount)))
        )
        (setq acount (+ acount 1))
       ) ; end while                                 ;;End loop

      (setq acount 0)                                ;;reset counter
      (while (< acount (length tenslist))            ;;Loop the number of vertices
        (setq removelist (LM:RemoveNth (+ acount 1) tenslist)) ;;Remove vertex acount + 1 position from list
        (setq removelist (LM:RemoveNth acount removelist))     ;;Remove vertex acount position from list
        (setq MyEnt (entget MyPoly))
        (foreach n (reverse removelist)              ;;remove the remaining vertext position from entity definition
          (setq MyEnt (LM:RemoveNth n MyEnt))
        )
        (entmakex MyEnt)                             ;;Make a new polyline using acount, acount + 1 positions
        (setq acount (+ acount 2))
      ) ; end while                                  ;;end loop
    ) ; end progn
  )
  (entdel MyPoly)                                    ;;Delete original line
  (princ)
)

 

Edited October 31, 2023 by Steven P

[Jamesclark64]

On 29/10/2023 at 20:12, Steven P said:

Barely an inconvenience...

 

This should work for LWpolylines, command id "OddSegments2

 

(defun c:oddsegments ( / MyPoly LastEnt Verticies acount )
  ;;SubFunctions
  (defun mAssoc ( key lst / result ) ; https://www.cadtutor.net/forum/topic/27914-massoc-implementations/
    (foreach x lst
      (if (= key (car x)) (setq result (cons (cdr x) result)) )
    )
    (reverse result)
  )
  ;;End Sub Functions

  (setq MyPoly (car (entsel "Select PolyLine: ")))      ;;Select Polyline
  (if (= (cdr (assoc 0 (entget MyPoly))) "LWPOLYLINE")  ;;Check a LWPolyLine was selected
    (progn
      (setq LastEnt (entlast))                          ;;Find the marker for the last entity created
      (setq Verticies (length (mAssoc 10 (entget MyPoly)))) ;;returns the coordinates
      (command "copy" MyPoly "" '(0 0 0) '(0 0 0) "")(entdel MyPoly) ;;copy and delete the existing line
      (command "Explode" (entlast))                     ;;explode the new line
      (setq acount 1)                                   ;;A counter
      (while (< acount verticies)                       ;;a loop if counter is less then no, of veritcies
        (setq LastEnt (entnext LastEnt))                ;;get first segment of copied polyline
        (setq acount (+ acount 1))                      ;;increment counter
        (setq LastEnt (entnext LastEnt))                ;;get next segment of copied polyline
        (if (< acount verticies)(entdel LastEnt))       ;;Delete the segment as required
        (setq acount (+ acount 1))                      ;;Increase counter
      ) ; end while                                     ;;end loop
    ) ; end progn
    (princ "PolyLine Not Selected")                     ;;if polyline wasn't selected
  ) ; end if
)

 

This is exactly what I was after thank you so much. 

[ronjonp]

Another for fun .. does not keep polyline widths..

(defun c:foo (/ n pcs s)
  (cond	((setq s (ssget ":L" '((0 . "LWPOLYLINE"))))
	 (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
	   (setq n (length (setq pcs (vlax-invoke (vlax-ename->vla-object e) 'explode))))
	   (foreach pc pcs
	     (if (= 0 (rem (setq n (1- n)) 2))
	       (vla-delete pc)
	       (vla-put-color pc 3)
	     )
	   )
	   (entdel e)
	 )
	)
  )
  (princ)
)