motee-z Posted November 18, 2016 Posted November 18, 2016 any help for a lisp to convert a selection set of lines to 3dpolylines thanks for any kind of help Quote
marko_ribar Posted November 18, 2016 Posted November 18, 2016 (defun c:l3dpl ( / UNIQUE CHOICE1 CHOICE2 ENENT ENPT ENPTT ENT K NXTENTEN NXTENTST OSM PTLST SEPT SEPTN SEPTS SS SSS STENT STPT ) (defun unique ( L FUZZ ) (if l (cons (car l) (vl-remove-if '(lambda ( x ) (equal x (car l) fuzz)) (unique (cdr l))))) ) (vl-cmdf "_.UCS" "w") (setq osm (getvar 'osmode)) (setvar 'osmode 0) (prompt "\nSelect all connected lines") (setq ss (ssget '((0 . "LINE")) )) (setq sss (ssadd)) (repeat (setq k (sslength ss)) (setq ent (ssname ss (setq k (1- k)))) (ssadd ent sss) ) (repeat (setq k (sslength ss)) (setq ent (ssname ss (setq k (1- k)))) (setq stpt (cdr (assoc 10 (entget ent)))) (setq enpt (cdr (assoc 11 (entget ent)))) (setq septs (cons stpt septs)) (setq septs (cons enpt septs)) ) (setq sept septs) (defun chkduppt (pt lst / chk) (foreach ptt lst (if (equal pt ptt 1e-6) (setq chk (cons T chk))) ) chk ) (foreach pt septs (if (eq (length (chkduppt pt septs)) 2) (setq septn (cons pt septn))) ) (foreach pt septn (setq sept (vl-remove pt sept)) ) (if (eq sept nil) (setq sept (unique septs 1e-6))) (repeat (setq k (sslength ss)) (setq ent (ssname ss (setq k (1- k)))) (setq stpt (cdr (assoc 10 (entget ent)))) (if (equal stpt (car sept) 1e-6) (setq stent ent)) ) (if (eq stent nil) (repeat (setq k (sslength ss)) (setq ent (ssname ss (setq k (1- k)))) (setq enpt (cdr (assoc 11 (entget ent)))) (if (equal enpt (car sept) 1e-6) (setq enent ent)) ) ) (if stent (progn (setq ptlst (cons (cdr (assoc 10 (entget stent))) ptlst)) (setq ptlst (cons (cdr (assoc 11 (entget stent))) ptlst)) (setq enpt (cdr (assoc 11 (entget stent)))) (ssdel stent ss) ) (progn (setq ptlst (cons (cdr (assoc 11 (entget enent))) ptlst)) (setq ptlst (cons (cdr (assoc 10 (entget enent))) ptlst)) (setq enpt (cdr (assoc 10 (entget enent)))) (ssdel enent ss) ) ) (while (/= (sslength ss) 0) (setq nxtentst nil) (setq nxtenten nil) (repeat (setq k (sslength ss)) (setq ent (ssname ss (setq k (1- k)))) (setq stpt (cdr (assoc 10 (entget ent)))) (if (equal enpt stpt 1e-6) (setq nxtentst ent)) ) (if nxtentst nil (repeat (setq k (sslength ss)) (setq ent (ssname ss (setq k (1- k)))) (setq enptt (cdr (assoc 11 (entget ent)))) (if (equal enpt enptt 1e-6) (setq nxtenten ent)) ) ) (if nxtentst (progn (setq ptlst (cons (cdr (assoc 10 (entget nxtentst))) ptlst)) (setq ptlst (cons (cdr (assoc 11 (entget nxtentst))) ptlst)) (setq enpt (cdr (assoc 11 (entget nxtentst)))) (ssdel nxtentst ss) ) (progn (setq ptlst (cons (cdr (assoc 11 (entget nxtenten))) ptlst)) (setq ptlst (cons (cdr (assoc 10 (entget nxtenten))) ptlst)) (setq enpt (cdr (assoc 10 (entget nxtenten)))) (ssdel nxtenten ss) ) ) ) (setq ptlst (unique ptlst 1e-6)) (initget 1 "Open Close") (setq choice1 (getkword "\nIs 3dpolyline opened or closed (Open/Close) : ")) (if (eq choice1 "Open") (progn (command "_.3dpoly") (foreach pt ptlst (command pt) ) (command "") ) (progn (command "_.3dpoly") (foreach pt ptlst (command pt) ) (command "c") ) ) (initget 1 "Keep Delete") (setq choice2 (getkword "\nDo you want to keep lines, or do you want me to delete them (Keep/Delete) : ")) (if (eq choice2 "Delete") (command "erase" sss "") ) (vl-cmdf "_.UCS" "p") (setvar 'osmode osm) (princ) ) HTH. M.R. Quote
motee-z Posted November 18, 2016 Author Posted November 18, 2016 thank you marko for you reply i tried your lisp the lines still lines not converted to 3d polylines one more think the lines set have z elevation and these line not necessary contected Quote
BIGAL Posted November 18, 2016 Posted November 18, 2016 If the lines are not connected this opens a can of worms what rules apply to connect them ? If the ends are close and have different Z's which do you use when joining ? (prompt "\nSelect all connected lines") Quote
marko_ribar Posted November 27, 2016 Posted November 27, 2016 (edited) Better ever, than never... (defun c:joinlines23dpolys ( / *error* _vl-position uniquechain adoc ss ti elst el1 el2 el3 ee e eg egg entl pl p pp f chainl vertl vts tmp ) (vl-load-com) (defun *error* ( m ) (vla-endundomark adoc) (if m (prompt m) ) (princ) ) ;; (_vl-position 3.29 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9) 0.01 nil) => 2 (!k => nil) ;; (defun _vl-position ( e l tol k ) (if (null k) (setq k 0) ) (if (not (equal e (car l) tol)) (progn (setq k (1+ k)) (if (cdr l) (_vl-position e (cdr l) tol k) (setq k nil) ) ) k ) ) (defun uniquechain ( l ) (if l (cons (car l) (uniquechain (vl-remove-if '(lambda ( x ) (or (and (equal (caar l) (car x) 1e-6) (equal (cadar l) (cadr x) 1e-6)) (and (equal (caar l) (cadr x) 1e-6) (equal (cadar l) (car x) 1e-6)))) l)))) ) (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) (setq ss (ssget "_:L" '((0 . "LINE")))) (setq ti (car (_vl-times))) (setq elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) (setq entl (mapcar '(lambda ( x ) (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x) x)) elst)) (setq entl (uniquechain entl)) (foreach e elst (entdel e) ) (setq elst (mapcar 'caddr entl)) (foreach e elst (entdel e) ) (foreach e elst (cond ( (and (not (vl-some '(lambda ( x ) (or (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6) )) (setq tmp (vl-remove e elst)) ) ) (not (vl-some '(lambda ( x ) (or (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6) )) tmp ) ) ) (setq el1 (cons e el1)) ) ( (and (vl-some '(lambda ( x ) (or (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6) )) tmp ) (vl-some '(lambda ( x ) (or (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6) )) tmp ) ) (setq el3 (cons e el3)) ) ( t ;| (or (and (vl-some '(lambda ( x ) (or (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6) ) ) tmp) (not (vl-some '(lambda ( x ) (or (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6) ) ) tmp) ) ) (and (not (vl-some '(lambda ( x ) (or (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6) ) ) tmp) ) (vl-some '(lambda ( x ) (or (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6) ) ) tmp) ) ) |; (setq el2 (cons e el2)) ) ) ) (setq elst (append el1 el2 el3)) (while (or ee (setq e (car elst))) (if (vl-some '(lambda ( x ) (or (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6) (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6) ) ) (setq tmp (vl-remove e elst)) ) (cond ( (vl-some '(lambda ( x ) (if (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6) (setq ee x) (setq ee nil))) tmp) (if (not (vl-position e eg)) (setq eg (cons e eg)) ) ) ( (vl-some '(lambda ( x ) (if (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6) (setq ee x) (setq ee nil))) tmp) (if (not (vl-position e eg)) (setq eg (cons e eg)) ) ) ( (vl-some '(lambda ( x ) (if (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6) (setq ee x) (setq ee nil))) tmp) (if (not (vl-position e eg)) (setq eg (cons e eg)) ) ) ( (vl-some '(lambda ( x ) (if (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6) (setq ee x) (setq ee nil))) tmp) (if (not (vl-position e eg)) (setq eg (cons e eg)) ) ) ) (if (null eg) (setq eg (cons e eg) egg (cons eg egg) ee nil eg nil) (progn (if (not (vl-position e eg)) (setq eg (cons e eg)) ) (setq ee nil egg (cons eg egg) eg nil) ) ) ) (setq elst (vl-remove e elst)) (if ee (setq e ee) ) ) (foreach eg egg (if (/= (length eg) 1) (while (> (length eg) 1) (setq pp nil f nil) (setq entl (mapcar '(lambda ( x ) (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x) x)) eg)) (setq pl (vl-remove-if '(lambda ( x ) (= (type x) 'ENAME)) (apply 'append entl))) (while (setq p (car pl)) (if (_vl-position p (cdr pl) 1e-6 nil) (setq pl (vl-remove-if '(lambda ( x ) (equal p x 1e-6)) pl)) (setq pp p pl (cdr pl)) ) ) (if pp (setq e (vl-some '(lambda ( x ) (if (or (equal (car x) pp 1e-6) (equal (cadr x) pp 1e-6)) x)) entl)) (setq e (car entl)) ) (while e (setq chainl (cons e chainl)) (setq e (vl-some '(lambda ( x ) (cond ( (and pp (= (length chainl) 1)) (if (equal (car e) pp 1e-6) (cond ( (equal (cadr e) (car x) 1e-6) (setq f t) x ) ( (equal (cadr e) (cadr x) 1e-6) (setq f nil) x ) ) (cond ( (equal (car e) (car x) 1e-6) (setq f t) x ) ( (equal (car e) (cadr x) 1e-6) (setq f nil) x ) ) ) ) ( (= (length chainl) 1) (cond ( (equal (cadr e) (car x) 1e-6) (setq f t) x ) ( (equal (cadr e) (cadr x) 1e-6) (setq f nil) x ) ) ) ( t (cond ( (and f (equal (cadr e) (car x) 1e-6)) (setq f t) x ) ( (and f (equal (cadr e) (cadr x) 1e-6)) (setq f nil) x ) ( (and (null f) (equal (car e) (car x) 1e-6)) (setq f t) x ) ( (and (null f) (equal (car e) (cadr x) 1e-6)) (setq f nil) x ) ) ) ) ) (setq entl (vl-remove e entl)) ) ) ) (setq chainl (reverse chainl)) (if pp (setq vertl (append (list (if (equal (caar chainl) pp 1e-6) (caar chainl) (cadar chainl))) (setq vts (mapcar '(lambda ( a b ) (cond ( (equal (car a) (car b) 1e-6) (car a) ) ( (equal (car a) (cadr b) 1e-6) (car a) ) ( (equal (cadr a) (car b) 1e-6) (cadr a) ) ( (equal (cadr a) (cadr b) 1e-6) (cadr a) ) )) chainl (cdr chainl))) (vl-remove-if '(lambda ( x ) (equal x (last vts) 1e-6)) (vl-remove-if '(lambda ( x ) (= (type x) 'ENAME)) (last chainl))))) (setq vertl (append (list (caar chainl)) (mapcar '(lambda ( a b ) (cond ( (equal (car a) (car b) 1e-6) (car a) ) ( (equal (car a) (cadr b) 1e-6) (car a) ) ( (equal (cadr a) (car b) 1e-6) (cadr a) ) ( (equal (cadr a) (cadr b) 1e-6) (cadr a) ) )) chainl (cdr chainl)))) ) (foreach chain chainl (setq eg (vl-remove (caddr chain) eg)) (entdel (caddr chain)) ) (setq chainl nil) (if (car vertl) (progn (entmake (list '(0 . "POLYLINE") '(100 . "AcDbEntity") '(100 . "AcDb3dPolyline") '(66 . 1) '(10 0.0 0.0 0.0) (if pp (cons 70 (cons 70 9) ) '(210 0.0 0.0 1.0) ) ) (foreach pt vertl (entmake (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(100 . "AcDbVertex") '(100 . "AcDb3dPolylineVertex") (cons 10 pt) '(70 . 32) ) ) ) (entmake (list '(0 . "SEQEND") '(100 . "AcDbEntity") ) ) ) ) (setq vertl nil) ) ) ) (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 20)) (prompt " seconds...") (*error* nil) ) HTH. M.R. Edited December 8, 2016 by marko_ribar code changed - works slower but reliable results... Quote
marko_ribar Posted December 1, 2016 Posted December 1, 2016 (edited) Here is faster version - without prior sorting of lines... Should be also 100% reliable... (defun c:joinlines23dpolys ( / *error* _vl-position uniquechain adoc ss ti elst e e1 ee eg egg entl pl p pp f chainl vertl vts tmp ) (vl-load-com) (defun *error* ( m ) (vla-endundomark adoc) (if m (prompt m) ) (princ) ) ;; (_vl-position 3.29 '(1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8 9.9) 0.01 nil) => 2 (!k => nil) ;; (defun _vl-position ( e l tol k ) (if (null k) (setq k 0) ) (if (not (equal e (car l) tol)) (progn (setq k (1+ k)) (if (cdr l) (_vl-position e (cdr l) tol k) (setq k nil) ) ) k ) ) (defun uniquechain ( l ) (if l (cons (car l) (uniquechain (vl-remove-if '(lambda ( x ) (or (and (equal (caar l) (car x) 1e-6) (equal (cadar l) (cadr x) 1e-6)) (and (equal (caar l) (cadr x) 1e-6) (equal (cadar l) (car x) 1e-6)))) l)))) ) (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) (setq ss (ssget "_:L" '((0 . "LINE")))) (setq ti (car (_vl-times))) (setq elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) (setq entl (mapcar '(lambda ( x ) (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x) x)) elst)) (setq entl (uniquechain entl)) (foreach e elst (entdel e) ) (setq elst (mapcar 'caddr entl)) (foreach e elst (entdel e) ) (while (or ee (setq e (car elst) e1 e)) (if (vl-some '(lambda ( x ) (or (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6) (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6) (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6) ) ) (setq tmp (vl-remove e elst)) ) (cond ( (vl-some '(lambda ( x ) (if (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6) (setq ee x) (setq ee nil))) tmp) (if (not (vl-position e eg)) (setq eg (cons e eg)) ) ) ( (vl-some '(lambda ( x ) (if (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6) (setq ee x) (setq ee nil))) tmp) (if (not (vl-position e eg)) (setq eg (cons e eg)) ) ) ( (vl-some '(lambda ( x ) (if (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6) (setq ee x) (setq ee nil))) tmp) (if (not (vl-position e eg)) (setq eg (cons e eg)) ) ) ( (vl-some '(lambda ( x ) (if (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6) (setq ee x) (setq ee nil))) tmp) (if (not (vl-position e eg)) (setq eg (cons e eg)) ) ) ) (if (null eg) (setq eg (cons e eg) egg (cons eg egg) ee nil eg nil f nil) (if (null f) (progn (if (not (vl-position e eg)) (setq eg (cons e eg)) ) (setq ee e1 f t) ) (progn (if (not (vl-position e eg)) (setq eg (cons e eg)) ) (setq ee nil egg (cons eg egg) eg nil f nil) ) ) ) ) (setq elst (vl-remove e elst)) (if ee (setq e ee) ) ) (foreach eg egg (if (/= (length eg) 1) (while (> (length eg) 1) (setq pp nil f nil) (setq entl (mapcar '(lambda ( x ) (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x) x)) eg)) (setq pl (vl-remove-if '(lambda ( x ) (= (type x) 'ENAME)) (apply 'append entl))) (while (setq p (car pl)) (if (_vl-position p (cdr pl) 1e-6 nil) (setq pl (vl-remove-if '(lambda ( x ) (equal p x 1e-6)) pl)) (setq pp p pl (cdr pl)) ) ) (if pp (setq e (vl-some '(lambda ( x ) (if (or (equal (car x) pp 1e-6) (equal (cadr x) pp 1e-6)) x)) entl)) (setq e (car entl)) ) (while e (setq chainl (cons e chainl)) (setq e (vl-some '(lambda ( x ) (cond ( (and pp (= (length chainl) 1)) (if (equal (car e) pp 1e-6) (cond ( (equal (cadr e) (car x) 1e-6) (setq f t) x ) ( (equal (cadr e) (cadr x) 1e-6) (setq f nil) x ) ) (cond ( (equal (car e) (car x) 1e-6) (setq f t) x ) ( (equal (car e) (cadr x) 1e-6) (setq f nil) x ) ) ) ) ( (= (length chainl) 1) (cond ( (equal (cadr e) (car x) 1e-6) (setq f t) x ) ( (equal (cadr e) (cadr x) 1e-6) (setq f nil) x ) ) ) ( t (cond ( (and f (equal (cadr e) (car x) 1e-6)) (setq f t) x ) ( (and f (equal (cadr e) (cadr x) 1e-6)) (setq f nil) x ) ( (and (null f) (equal (car e) (car x) 1e-6)) (setq f t) x ) ( (and (null f) (equal (car e) (cadr x) 1e-6)) (setq f nil) x ) ) ) ) ) (setq entl (vl-remove e entl)) ) ) ) (setq chainl (reverse chainl)) (if pp (setq vertl (append (list (if (equal (caar chainl) pp 1e-6) (caar chainl) (cadar chainl))) (setq vts (mapcar '(lambda ( a b ) (cond ( (equal (car a) (car b) 1e-6) (car a) ) ( (equal (car a) (cadr b) 1e-6) (car a) ) ( (equal (cadr a) (car b) 1e-6) (cadr a) ) ( (equal (cadr a) (cadr b) 1e-6) (cadr a) ) )) chainl (cdr chainl))) (vl-remove-if '(lambda ( x ) (equal x (last vts) 1e-6)) (vl-remove-if '(lambda ( x ) (= (type x) 'ENAME)) (last chainl))))) (setq vertl (append (list (caar chainl)) (mapcar '(lambda ( a b ) (cond ( (equal (car a) (car b) 1e-6) (car a) ) ( (equal (car a) (cadr b) 1e-6) (car a) ) ( (equal (cadr a) (car b) 1e-6) (cadr a) ) ( (equal (cadr a) (cadr b) 1e-6) (cadr a) ) )) chainl (cdr chainl)))) ) (foreach chain chainl (setq eg (vl-remove (caddr chain) eg)) (entdel (caddr chain)) ) (setq chainl nil) (if (car vertl) (progn (entmake (list '(0 . "POLYLINE") '(100 . "AcDbEntity") '(100 . "AcDb3dPolyline") '(66 . 1) '(10 0.0 0.0 0.0) (if pp (cons 70 (cons 70 9) ) '(210 0.0 0.0 1.0) ) ) (foreach pt vertl (entmake (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(100 . "AcDbVertex") '(100 . "AcDb3dPolylineVertex") (cons 10 pt) '(70 . 32) ) ) ) (entmake (list '(0 . "SEQEND") '(100 . "AcDbEntity") ) ) ) ) (setq vertl nil) ) ) ) (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 20)) (prompt " seconds...") (*error* nil) ) HTH., M.R. Edited December 8, 2016 by marko_ribar Quote
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.