Jamesclark64 Posted March 2 Share Posted March 2 (edited) A while back I asked for some help with a routine that could trim unwanted segments of a poly line. original post: Steven P came up with a solution that works perfectly. However I've been trying to make a second version that deletes every third section of the poly line.(example below) but haven't had any luckany help would be greatly appreciated. (Edit) Steven P original code: (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 March 2 by Jamesclark64 Quote Link to comment Share on other sites More sharing options...
Steven P Posted March 2 Share Posted March 2 I think make this line: (setq acount (+ acount 2)) to (setq acount (+ acount 3)) Quote Link to comment Share on other sites More sharing options...
Steven P Posted March 2 Share Posted March 2 I'll check next week (if I remember, if not remind me), I think adding a 'remove every nth' user control would make this more versatile and maybe better? Quote Link to comment Share on other sites More sharing options...
Tsuky Posted March 3 Share Posted March 3 @Jamesclark64 This can do the job? (vl-load-com) (defun cut@point (ss lst_pt / n ename dxf_10 rtn_ss pt_brk lst_brk lst_sort dxf_obj dxf_43 dxf_38 dxf_39 dxf_10 dxf_40 dxf_41 dxf_42 dxf_210 ltmp lst_tmp where count nwent indx) (repeat (setq n (sslength ss)) (setq ename (ssname ss (setq n (1- n))) dxf_10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ename))) rtn_ss (ssadd) ) (foreach el (mapcar '(lambda (x) (trans x 0 ename)) lst_pt) (setq pt_brk el lst_brk (cons el lst_brk) ) ) (setq lst_sort (mapcar '(lambda (x) (list (vlax-curve-GetDistAtPoint ename (trans x ename 0)) (list (car x) (cadr x)))) lst_brk) lst_brk (reverse (mapcar 'cadr (mapcar '(lambda (x) (assoc x lst_sort)) (vl-sort (mapcar 'car lst_sort) '<)))) dxf_obj (entget ename) ) (if (cdr (assoc 43 dxf_obj)) (setq dxf_43 (cdr (assoc 43 dxf_obj))) (setq dxf_43 0.0) ) (if (cdr (assoc 38 dxf_obj)) (setq dxf_38 (cdr (assoc 38 dxf_obj))) (setq dxf_38 0.0) ) (if (cdr (assoc 39 dxf_obj)) (setq dxf_39 (cdr (assoc 39 dxf_obj))) (setq dxf_39 0.0) ) (setq dxf_10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_obj)) dxf_40 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 40)) dxf_obj)) dxf_41 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 41)) dxf_obj)) dxf_42 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) dxf_obj)) dxf_210 (cdr (assoc 210 dxf_obj)) ) (if (not (zerop (boole 1 (cdr (assoc 70 dxf_obj)) 1))) (setq dxf_10 (append dxf_10 (list (car dxf_10))) dxf_40 (append dxf_40 (list (car dxf_40))) dxf_41 (append dxf_41 (list (car dxf_41))) dxf_42 (append dxf_42 (list (car dxf_42))) ) ) (repeat (1+ (length lst_brk)) (setq ltmp nil lst_tmp (vl-member-if '(lambda (x) (and (equal (car x) (caar lst_brk) 1E-08) (equal (cadr x) (cadar lst_brk) 1E-08))) dxf_10) where (if lst_tmp (vl-position (car lst_tmp) dxf_10) 0) ) (repeat (setq count (- (length dxf_10) where)) (setq ltmp (cons (mapcar '(lambda (x y) (cons y (nth where x))) (list dxf_10 dxf_40 dxf_41 dxf_42) (list 10 40 41 42)) ltmp)) (setq where (1+ where)) ) (entmake (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (assoc 67 dxf_obj) (assoc 410 dxf_obj) (assoc 8 dxf_obj) (if (assoc 62 dxf_obj) (assoc 62 dxf_obj) (cons 62 256)) (if (assoc 6 dxf_obj) (assoc 6 dxf_obj) (cons 6 "BYLAYER")) (if (assoc 370 dxf_obj) (assoc 370 dxf_obj) (cons 370 -1)) (cons 100 "AcDbPolyline") (cons 90 (length ltmp)) (cons 70 (boole 1 (cdr (assoc 70 dxf_obj)) 128)) (cons 38 dxf_38) (cons 39 dxf_39) ) (apply 'append (reverse ltmp)) (list (cons 210 dxf_210)) ) ) (repeat (1- count) (setq dxf_10 (reverse (cdr (reverse dxf_10))) dxf_40 (reverse (cdr (reverse dxf_40))) dxf_41 (reverse (cdr (reverse dxf_41))) dxf_42 (reverse (cdr (reverse dxf_42))) ) ) (setq lst_brk (cdr lst_brk) ltmp nil nwent (entlast) rtn_ss (ssadd nwent rtn_ss)) ) (setq indx (1- (sslength rtn_ss))) (repeat (sslength rtn_ss) (if (eq (boole 1 indx 1) 1) (entdel (ssname rtn_ss indx)) ) (setq indx (1- indx)) ) (entdel ename) ) ) (defun c:altern_poly ( / ss n ss_save ent dxf_ent lst_pt brk_pt) (while (not (setq ss (ssget '((0 . "LWPOLYLINE")))))) (repeat (setq n (sslength ss)) (setq ss_save (ssadd) ent (ssname ss (setq n (1- n))) ss_save (ssadd ent ss_save) dxf_ent (entget ent) lst_pt (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) dxf_ent)) ) (if (equal (append (car lst_pt) (list (getvar "ELEVATION"))) (vlax-curve-getendpoint ent) 1E-08) (setq lst_pt (append lst_pt (list (car lst_pt)))) ) (if (>= (length lst_pt) 3) (progn (setq brk_pt nil) (while (and lst_pt (cadddr lst_pt)) (setq brk_pt (cons (caddr lst_pt) brk_pt) lst_pt (cdddr lst_pt) brk_pt (cons (car lst_pt) brk_pt) ) ) (if (eq (boole 1 (cdr (assoc 70 dxf_ent)) 1) 1) (setq brk_pt (cdr brk_pt))) (cut@point ss_save brk_pt) ) ) ) (prin1) ) 1 Quote Link to comment Share on other sites More sharing options...
Steven P Posted March 3 Share Posted March 3 (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 Remove (getint "Remove every nth Line: ")) (if (= Remove 1)(princ "Are you sure, this will remove every line (delete polyline)?") (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 tenslist) ;;List of vertexes to remove (setq counter (- Remove 1)) ;;A counter, remember 1st is zero (while (> counter -1) ;;Loop remove vertex list (setq removelist (LM:RemoveNth (+ acount counter) removelist)) ;;Remove vertex acount position from list (setq counter (- counter 1)) ) ; end while (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 Remove)) ) ; end while ;;end loop ) ; end progn ) (entdel MyPoly) ;;Delete original line (princ) ) Try this, command is oddeven again, and this version will ask which single vertex to remove (as above, delete every 3rd, or in the original every other, or even every 100th) Suppose it could even be altered to add "start vertex" and "number of vertex to remove" but that isn't for a Sunday night though Quote Link to comment Share on other sites More sharing options...
Jamesclark64 Posted March 4 Author Share Posted March 4 Fantastic work can't thank you enough. Quote Link to comment Share on other sites More sharing options...
Jamesclark64 Posted March 4 Author Share Posted March 4 On 03/03/2024 at 03:40, Tsuky said: @Jamesclark64 This can do the job? (vl-load-com) (defun cut@point (ss lst_pt / n ename dxf_10 rtn_ss pt_brk lst_brk lst_sort dxf_obj dxf_43 dxf_38 dxf_39 dxf_10 dxf_40 dxf_41 dxf_42 dxf_210 ltmp lst_tmp where count nwent indx) (repeat (setq n (sslength ss)) (setq ename (ssname ss (setq n (1- n))) dxf_10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ename))) rtn_ss (ssadd) ) (foreach el (mapcar '(lambda (x) (trans x 0 ename)) lst_pt) (setq pt_brk el lst_brk (cons el lst_brk) ) ) (setq lst_sort (mapcar '(lambda (x) (list (vlax-curve-GetDistAtPoint ename (trans x ename 0)) (list (car x) (cadr x)))) lst_brk) lst_brk (reverse (mapcar 'cadr (mapcar '(lambda (x) (assoc x lst_sort)) (vl-sort (mapcar 'car lst_sort) '<)))) dxf_obj (entget ename) ) (if (cdr (assoc 43 dxf_obj)) (setq dxf_43 (cdr (assoc 43 dxf_obj))) (setq dxf_43 0.0) ) (if (cdr (assoc 38 dxf_obj)) (setq dxf_38 (cdr (assoc 38 dxf_obj))) (setq dxf_38 0.0) ) (if (cdr (assoc 39 dxf_obj)) (setq dxf_39 (cdr (assoc 39 dxf_obj))) (setq dxf_39 0.0) ) (setq dxf_10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_obj)) dxf_40 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 40)) dxf_obj)) dxf_41 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 41)) dxf_obj)) dxf_42 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) dxf_obj)) dxf_210 (cdr (assoc 210 dxf_obj)) ) (if (not (zerop (boole 1 (cdr (assoc 70 dxf_obj)) 1))) (setq dxf_10 (append dxf_10 (list (car dxf_10))) dxf_40 (append dxf_40 (list (car dxf_40))) dxf_41 (append dxf_41 (list (car dxf_41))) dxf_42 (append dxf_42 (list (car dxf_42))) ) ) (repeat (1+ (length lst_brk)) (setq ltmp nil lst_tmp (vl-member-if '(lambda (x) (and (equal (car x) (caar lst_brk) 1E-08) (equal (cadr x) (cadar lst_brk) 1E-08))) dxf_10) where (if lst_tmp (vl-position (car lst_tmp) dxf_10) 0) ) (repeat (setq count (- (length dxf_10) where)) (setq ltmp (cons (mapcar '(lambda (x y) (cons y (nth where x))) (list dxf_10 dxf_40 dxf_41 dxf_42) (list 10 40 41 42)) ltmp)) (setq where (1+ where)) ) (entmake (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (assoc 67 dxf_obj) (assoc 410 dxf_obj) (assoc 8 dxf_obj) (if (assoc 62 dxf_obj) (assoc 62 dxf_obj) (cons 62 256)) (if (assoc 6 dxf_obj) (assoc 6 dxf_obj) (cons 6 "BYLAYER")) (if (assoc 370 dxf_obj) (assoc 370 dxf_obj) (cons 370 -1)) (cons 100 "AcDbPolyline") (cons 90 (length ltmp)) (cons 70 (boole 1 (cdr (assoc 70 dxf_obj)) 128)) (cons 38 dxf_38) (cons 39 dxf_39) ) (apply 'append (reverse ltmp)) (list (cons 210 dxf_210)) ) ) (repeat (1- count) (setq dxf_10 (reverse (cdr (reverse dxf_10))) dxf_40 (reverse (cdr (reverse dxf_40))) dxf_41 (reverse (cdr (reverse dxf_41))) dxf_42 (reverse (cdr (reverse dxf_42))) ) ) (setq lst_brk (cdr lst_brk) ltmp nil nwent (entlast) rtn_ss (ssadd nwent rtn_ss)) ) (setq indx (1- (sslength rtn_ss))) (repeat (sslength rtn_ss) (if (eq (boole 1 indx 1) 1) (entdel (ssname rtn_ss indx)) ) (setq indx (1- indx)) ) (entdel ename) ) ) (defun c:altern_poly ( / ss n ss_save ent dxf_ent lst_pt brk_pt) (while (not (setq ss (ssget '((0 . "LWPOLYLINE")))))) (repeat (setq n (sslength ss)) (setq ss_save (ssadd) ent (ssname ss (setq n (1- n))) ss_save (ssadd ent ss_save) dxf_ent (entget ent) lst_pt (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) dxf_ent)) ) (if (equal (append (car lst_pt) (list (getvar "ELEVATION"))) (vlax-curve-getendpoint ent) 1E-08) (setq lst_pt (append lst_pt (list (car lst_pt)))) ) (if (>= (length lst_pt) 3) (progn (setq brk_pt nil) (while (and lst_pt (cadddr lst_pt)) (setq brk_pt (cons (caddr lst_pt) brk_pt) lst_pt (cdddr lst_pt) brk_pt (cons (car lst_pt) brk_pt) ) ) (if (eq (boole 1 (cdr (assoc 70 dxf_ent)) 1) 1) (setq brk_pt (cdr brk_pt))) (cut@point ss_save brk_pt) ) ) ) (prin1) ) Very nice. You whipped that up really from scratch in no time at all? Great work. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.