Guest Posted September 14, 2013 Share Posted September 14, 2013 Hello my friends i need a litle help. I have a problem with a drawing. I need to calculate and insert the length between points (1,2,3,4,5,....,18,19) along a polyline with more Segments. I dont know if any one have a lisp to do this. I need something like this 1) select the polyline 2)select the points or pick the points 3) give the text size 4)insert the distanse between the points Here is my drawing Thank you for your time ROAD.dwg Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted September 14, 2013 Share Posted September 14, 2013 (edited) Give this a try, this one is made just for your DWG... (defun unit ( v ) (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v) ) (defun mxv ( m v ) (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m) ) (defun v^v ( u v ) (mapcar '(lambda ( n ) (- (* (nth (car n) u) (nth (cadr n) v)) (* (nth (cadr n) u) (nth (car n) v)))) '((1 2) (2 0) (0 1))) ) (defun transptucs ( pt p1 p2 p3 / ux uy uz ) (setq uz (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)))) (setq ux (unit (mapcar '- p2 p1))) (setq uy (unit (mapcar '- p3 p1))) (mxv (list ux uy uz) (mapcar '- pt p1)) ) (defun transptwcs ( pt pt1 pt2 pt3 / pt1n pt2n pt3n ) (setq pt1n (transptucs '(0.0 0.0 0.0) pt1 pt2 pt3)) (setq pt2n (transptucs '(1.0 0.0 0.0) pt1 pt2 pt3)) (setq pt3n (transptucs '(0.0 1.0 0.0) pt1 pt2 pt3)) (transptucs pt pt1n pt2n pt3n) ) (defun hplv ( pl / el uz v vl ux uy ) (if (and (eq (cdr (assoc 0 (entget pl))) "POLYLINE") (< -1 (cdr (assoc 70 (entget pl))) 6)) (progn (setq el (last (cdr (assoc 10 (entget pl))))) (setq uz (cdr (assoc 210 (entget pl)))) (setq v pl) (while (eq (cdr (assoc 0 (entget (setq v (entnext v))))) "VERTEX") (setq vl (cons (list (car (cdr (assoc 10 (entget v)))) (cadr (cdr (assoc 10 (entget v)))) el) vl)) ) (if (equal uz '(0.0 0.0 1.0) 1e- (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0))) (if (equal uz '(0.0 0.0 -1.0) 1e- (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0))) (if (not (or (equal uz '(0.0 0.0 1.0) 1e- (equal uz '(0.0 0.0 -1.0) 1e-)) (setq ux (unit (v^v '(0.0 0.0 1.0) uz)))) (if (not uy) (setq uy (unit (v^v uz ux)))) (setq vl (mapcar '(lambda ( p ) (transptwcs p '(0.0 0.0 0.0) ux uy)) vl)) (reverse vl) ) (progn (prompt "\nNot valid pl agument supplied to function") (princ) ) ) ) (defun lplv ( pl / el uz vl ux uy ) (if (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE") (progn (setq el (cdr (assoc 38 (entget pl)))) (setq uz (cdr (assoc 210 (entget pl)))) (setq vl (mapcar 'cdr (vl-remove-if-not '(lambda ( p ) (= (car p) 10)) (entget pl)))) (setq vl (mapcar '(lambda ( p ) (list (car p) (cadr p) el)) vl)) (if (equal uz '(0.0 0.0 1.0) 1e- (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0))) (if (equal uz '(0.0 0.0 -1.0) 1e- (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0))) (if (not (or (equal uz '(0.0 0.0 1.0) 1e- (equal uz '(0.0 0.0 -1.0) 1e-)) (setq ux (unit (v^v '(0.0 0.0 1.0) uz)))) (if (not uy) (setq uy (unit (v^v uz ux)))) (setq vl (mapcar '(lambda ( p ) (transptwcs p '(0.0 0.0 0.0) ux uy)) vl)) vl ) (progn (prompt "\nNot valid pl agument supplied to function") (princ) ) ) ) (defun c:pl-pt-seg-pt-dist ( / att d dist12 number pl pt1 pt12m pt1r pt2 pt2r ptatttagname ptbl1 ptbl2 ptble ptblentl ptblentnl ptblname ssptbl txts vl ) (vl-load-com) (setq pl (car (entsel "\nPick 2d polyline"))) (if (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE") (setq vl (lplv pl)) (setq vl (hplv pl)) ) (setq ptblname (getstring t "\nSpecify name of block-point <KORYFES> : ")) (if (eq ptblname "") (setq ptblname "KORYFES")) (setq ptatttagname (getstring t "\nSpecify name of tag that represent point number of block-point <POINT> : ")) (if (eq ptatttagname "") (setq ptatttagname "POINT")) (initget 6) (setq txts (getreal (strcat "\nSpecify text size for pt-pt distances specification <" (rtos (getvar 'textsize)) "> : "))) (if (eq txts nil) (setq txts (getvar 'textsize))) (setq ssptbl (ssget "_X" (list '(0 . "INSERT") (cons 2 ptblname)))) (setq ptblentl (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssptbl)))) (foreach ptblent ptblentl (setq att ptblent) (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND")) (if (eq (cdr (assoc 2 (entget att))) ptatttagname) (setq number (atoi (cdr (assoc 1 (entget att))))) ) ) (setq ptble (list ptblent number)) (setq ptblentnl (cons ptble ptblentnl)) ) (setq ptblentnl (vl-sort ptblentnl '(lambda (a b) (< (cadr a) (cadr b))))) (repeat (- (length ptblentnl) 1) (setq ptbl1 (caar ptblentnl) ptbl2 (caadr ptblentnl) ) (setq pt1 (cdr (assoc 10 (entget ptbl1))) pt2 (cdr (assoc 10 (entget ptbl2))) ) (setq pt1r (car (vl-member-if '(lambda (x) (equal (list (car x) (cadr x)) (list (car pt1) (cadr pt1)) 1e-6)) vl)) pt2r (car (vl-member-if '(lambda (x) (equal (list (car x) (cadr x)) (list (car pt2) (cadr pt2)) 1e-6)) vl)) ) (if (null d) (setq d 0.0)) (setq dist12 (- (vlax-curve-getdistatpoint pl pt2r) (vlax-curve-getdistatpoint pl pt1r))) (setq pt12m (vlax-curve-getpointatdist pl (+ d (/ dist12 2.0)))) (entmake (list '(0 . "TEXT") (cons 10 pt12m) (cons 40 txts) (cons 1 (rtos dist12)) '(7 . "Standard") '(72 . 4) (cons 11 pt12m))) (setq d (+ d dist12)) (setq ptblentnl (cdr ptblentnl)) ) (princ) ) (defun c:plppd nil (c:pl-pt-seg-pt-dist)) M.R. Edited September 20, 2013 by marko_ribar replaced (while (setq att (entnext att)).) to (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND")).) Quote Link to comment Share on other sites More sharing options...
Guest Posted September 14, 2013 Share Posted September 14, 2013 nice job marko_ribar thanks. a) Is it possible to round up to 2 desimals places ? b)The text have an orientation problem can you fix it .For units use grads , clockwise and direction north Thanks Quote Link to comment Share on other sites More sharing options...
Guest Posted September 14, 2013 Share Posted September 14, 2013 I fix the (a) so i round up to 2 desimals I change this line (entmake (list '(0 . "TEXT") (cons 10 pt12m) (cons 40 txts) (cons 1 (rtos dist12)) '(7 . "Standard") '(72 . 4) (cons 11 pt12m))) with this line (entmake (list '(0 . "TEXT") (cons 10 pt12m) (cons 40 txts) (cons 1 (rtos dist12 2 2)) '(7 . "Standard") '(72 . 4) (cons 11 pt12m))) but i still have problem with the orientation ! any ideas .. Quote Link to comment Share on other sites More sharing options...
fixo Posted September 15, 2013 Share Posted September 15, 2013 Try this code, mostly borrowed from this forum guys ;;--------------------------------- pldist.lsp ------------------------------------;; (defun angtangent (pline pt) ;; by CAB (Charles Alan Butler) (angle '(0 0 0) (trans (vlax-curve-getFirstDeriv pline (vlax-curve-getParamAtPoint pline (trans pt 1 0)) ) 0 1 T ) ) ) (defun right-ang(ang /) (if (< (/ pi 2) ang (* pi 1.5)) (setq ang (+ ang pi))) ang ) (defun c:pldist(/ acsp adoc ang axsb coords da dist fder firstpt midpt mtx nextpt par plent pline points pts sb sp strdist) (setq adoc (vla-get-activeDocument (vlax-get-acad-object))) (if (and (= (getvar "tilemode") 0) (= (getvar "cvport") 1) ) (setq acsp (vla-get-paperspace adoc)) (setq acsp (vla-get-modelspace adoc)) ) (vla-startundoMark adoc) (prompt "\n >>> Select curve >>>\n") (setq sp nil) (while (not (or (and (setq sp (ssget "_+.:S:E" '((0 . "lwpolyline"))))))) (princ "\n\t---> Select lwpolyline only!")) (setq plent (ssname sp 0) pline (vlax-ename->vla-object plent) ) (command "_zoom" "_ob" plent "") (setq coords (vl-remove-if 'not (mapcar '(lambda (x)(if (= 10 (car x))(cdr x)))(entget plent)))) (setq sb (ssget "f" (vl-remove-if 'not (mapcar '(lambda (x)(if (= 10 (car x))(cdr x))) (entget plent))) (list (cons 0 "insert") (cons 2 "koryfes") ) ) ) (setq axsb (vla-get-activeselectionset adoc)) (vlax-for blkObj axsb (setq points (cons (vlax-get blkObj 'insertionpoint)points))) (setq pts (mapcar '(lambda(pt)(vlax-curve-getclosestpointto pline pt))points)) (setq pts(vl-sort pts '(lambda (a b) (< (vlax-curve-getdistatpoint pline a) (vlax-curve-getdistatpoint pline b) ) ) ) ) (while (setq nextpt(cadr pts)) (setq firstpt (car pts)) (setq dist (- (vlax-curve-getparamatpoint pline nextpt) (vlax-curve-getparamatpoint pline firstpt) ) ) (setq strdist (rtos dist 2 (getvar "dimdec"))) (setq midpt (vlax-curve-getclosestpointto pline (mapcar '(lambda (a b) (/ (+ a b) 2.0)) firstpt nextpt))) (setq ang (angtangent pline midpt)) (setq da (right-ang ang)) (setq mtx (vla-addmtext acsp (vlax-3d-point midpt) 0.0 strdist)) (vla-put-attachmentpoint mtx acattachmentpointbottomcenter) (vla-put-insertionpoint mtx (vlax-3d-point midpt)) (vla-put-height mtx 0.5 ;|(getvar "textsize")| (vla-put-rotation mtx da) (vla-put-stylename mtx (getvar "textstyle")) (setq pts (cdr pts)) ) (vla-endundoMark adoc) (princ) ) Quote Link to comment Share on other sites More sharing options...
Guest Posted September 15, 2013 Share Posted September 15, 2013 is not working to me ; error: ActiveX Server returned the error: unknown name: "INSERTIONPOINT" Quote Link to comment Share on other sites More sharing options...
Guest Posted September 15, 2013 Share Posted September 15, 2013 marko_ribar I have a problem with plppd.lsp. I tried to use it in another design but gives me this error ; error: bad argument type: 2D/3D point: nil I attach my drawing. In this occasion i move points ,2,3 and 4 not to be on segments but between two segments. ROAD2.dwg Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted September 16, 2013 Share Posted September 16, 2013 (edited) marko_ribar I have a problem with plppd.lsp. I tried to use it in another design but gives me this error I attach my drawing. In this occasion i move points ,2,3 and 4 not to be on segments but between two segments. Here is my simple modification that will suit your new situation... (defun c:pl-pt-seg-pt-dist ( / att d dist12 number pl pt1 pt12m pt1r pt2 pt2r ptatttagname ptbl1 ptbl2 ptble ptblentl ptblentnl ptblname ssptbl txts ) (vl-load-com) (setq pl (car (entsel "\nPick 2d polyline"))) (setq ptblname (getstring t "\nSpecify name of block-point <KORYFES> : ")) (if (eq ptblname "") (setq ptblname "KORYFES")) (setq ptatttagname (getstring t "\nSpecify name of tag that represent point number of block-point <POINT> : ")) (if (eq ptatttagname "") (setq ptatttagname "POINT")) (initget 6) (setq txts (getreal (strcat "\nSpecify text size for pt-pt distances specification <" (rtos (getvar 'textsize)) "> : "))) (if (eq txts nil) (setq txts (getvar 'textsize))) (setq ssptbl (ssget "_X" (list '(0 . "INSERT") (cons 2 ptblname)))) (setq ptblentl (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssptbl)))) (foreach ptblent ptblentl (setq att ptblent) (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND")) (if (eq (cdr (assoc 2 (entget att))) ptatttagname) (setq number (atoi (cdr (assoc 1 (entget att))))) ) ) (setq ptble (list ptblent number)) (setq ptblentnl (cons ptble ptblentnl)) ) (setq ptblentnl (vl-sort ptblentnl '(lambda (a b) (< (cadr a) (cadr b))))) (repeat (- (length ptblentnl) 1) (setq ptbl1 (caar ptblentnl) ptbl2 (caadr ptblentnl) ) (setq pt1 (cdr (assoc 10 (entget ptbl1))) pt2 (cdr (assoc 10 (entget ptbl2))) ) (setq pt1r (vlax-curve-getclosestpointto pl pt1) pt2r (vlax-curve-getclosestpointto pl pt2) ) (if (null d) (setq d 0.0)) (setq dist12 (- (vlax-curve-getdistatpoint pl pt2r) (vlax-curve-getdistatpoint pl pt1r))) (setq pt12m (vlax-curve-getpointatdist pl (+ d (/ dist12 2.0)))) (entmake (list '(0 . "TEXT") (cons 10 pt12m) (cons 40 txts) (cons 1 (rtos dist12 2 2)) '(7 . "Standard") '(72 . 4) (cons 11 pt12m))) (setq d (+ d dist12)) (setq ptblentnl (cdr ptblentnl)) ) (princ) ) (defun c:plppd nil (c:pl-pt-seg-pt-dist)) Edited September 16, 2013 by marko_ribar replaced (while (setq att (entnext att)).) to (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND")).) Quote Link to comment Share on other sites More sharing options...
Guest Posted September 16, 2013 Share Posted September 16, 2013 Sorry again Mr marko_ribar .Thank you for your time but It does not work correctly in all situations.I sent you a new example. I think that if 1) select the polyline 2) pick the points (so we will have the position of the point on the polyline) it will be better Drawing1.dwg Quote Link to comment Share on other sites More sharing options...
fixo Posted September 16, 2013 Share Posted September 16, 2013 is not working to me Add: (vl-load-com) at the start of routine Quote Link to comment Share on other sites More sharing options...
Guest Posted September 16, 2013 Share Posted September 16, 2013 Add: Code: (vl-load-com) at the start of routine I did it but gives me this error ; error: bad DXF group: (10); error: bad argument type: stringp nil Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted September 16, 2013 Share Posted September 16, 2013 I fixed my codes... Try it now... replaced (while (setq att (entnext att))...) to (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND"))...) It should work and in your second example Drawing1.dwg, only make sure you type correct block name "point" - it's case sensitive... M.R. Quote Link to comment Share on other sites More sharing options...
Guest Posted September 16, 2013 Share Posted September 16, 2013 I fixed my codes... Try it now... replaced (while (setq att (entnext att))...) to (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND"))...) It should work and in your second example Drawing1.dwg, only make sure you type correct block name "point" - it's case sensitive... M.R. I use this code (defun c:pl-pt-seg-pt-dist ( / att d dist12 number pl pt1 pt12m pt1r pt2 pt2r ptatttagname ptbl1 ptbl2 ptble ptblentl ptblentnl ptblname ssptbl txts ) (vl-load-com) (setq pl (car (entsel "\nPick 2d polyline"))) (setq ptblname (getstring t "\nSpecify name of block-point <KORYFES> : ")) (if (eq ptblname "") (setq ptblname "KORYFES")) (setq ptatttagname (getstring t "\nSpecify name of tag that represent point number of block-point <POINT> : ")) (if (eq ptatttagname "") (setq ptatttagname "POINT")) (initget 6) (setq txts (getreal (strcat "\nSpecify text size for pt-pt distances specification <" (rtos (getvar 'textsize)) "> : "))) (if (eq txts nil) (setq txts (getvar 'textsize))) (setq ssptbl (ssget "_X" (list '(0 . "INSERT") (cons 2 ptblname)))) (setq ptblentl (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssptbl)))) (foreach ptblent ptblentl (setq att ptblent) (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND")) (if (eq (cdr (assoc 2 (entget att))) ptatttagname) (setq number (atoi (cdr (assoc 1 (entget att))))) ) ) (setq ptble (list ptblent number)) (setq ptblentnl (cons ptble ptblentnl)) ) (setq ptblentnl (vl-sort ptblentnl '(lambda (a b) (< (cadr a) (cadr b))))) (repeat (- (length ptblentnl) 1) (setq ptbl1 (caar ptblentnl) ptbl2 (caadr ptblentnl) ) (setq pt1 (cdr (assoc 10 (entget ptbl1))) pt2 (cdr (assoc 10 (entget ptbl2))) ) (setq pt1r (vlax-curve-getclosestpointto pl pt1) pt2r (vlax-curve-getclosestpointto pl pt2) ) (if (null d) (setq d 0.0)) (setq dist12 (- (vlax-curve-getdistatpoint pl pt2r) (vlax-curve-getdistatpoint pl pt1r))) (setq pt12m (vlax-curve-getpointatdist pl (+ d (/ dist12 2.0)))) (entmake (list '(0 . "TEXT") (cons 10 pt12m) (cons 40 txts) (cons 1 (rtos dist12 2 2)) '(7 . "Standard") '(72 . 4) (cons 11 pt12m))) (setq d (+ d dist12)) (setq ptblentnl (cdr ptblentnl)) ) (princ) ) (defun c:plppd nil (c:pl-pt-seg-pt-dist)) but i still have some errors With red color (in the drawing) you will see them .. test2.dwg Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted September 16, 2013 Share Posted September 16, 2013 I have correct results on the very same drawing you posted... See attachment, what could be wrong??? Please, close CAD, open DWG, and load my code; you probably still had old one in CAD memory... Please, test it again, it works fine on my netboook... M.R. test2.dwg Quote Link to comment Share on other sites More sharing options...
Guest Posted September 16, 2013 Share Posted September 16, 2013 I have correct results on the very same drawing you posted... See attachment, what could be wrong??? Please, close CAD, open DWG, and load my code; you probably still had old one in CAD memory... Please, test it again, it works fine on my netboook... M.R. I unload all lisp files,close my autocad ,load again the plppd.lsp and i have the same problem. Please can you sent me your code .I don't know what happening with my autocad !! Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted September 16, 2013 Share Posted September 16, 2013 I unload all lisp files,close my autocad ,load again the plppd.lsp and i have the same problem. Please can you sent me your code .I don't know what happening with my autocad !! This is really weird, my code is the same I posted, but here is it... pl-pt-seg-pt-dist-new.lsp Quote Link to comment Share on other sites More sharing options...
Guest Posted September 16, 2013 Share Posted September 16, 2013 After 2 restart the lisp work.But i find another bug. if the numbers are 1,2,3,4,5,6,7,8,9,10 all is ok if the numbers are 1,2,3,4,15,6,7,18,9,10 the lengths are not correct if the numbers are k1,k2,S3,S4,S15,6,7,18,9,10 (for any letter S,s,A,a etc) the lengths are not correct can you fix this ? Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted September 16, 2013 Share Posted September 16, 2013 This is not a bug, the code was programmed according to exact array of numbers set up in block examining tag for witch routine prompts you to specify its name... Blocks with following number Tag description are to be placed in correct array and points that are represented with this block have to follow exact array of numeration from start to the end of polyline... This is only issue that has to be fulfilled in order for routine to function properly as it was designed for... Also if I may mention this code is applicable to any type of AcDbCurve entity, so polyline can be spline, line, xline, ray, arc, circle, ellipse, old heavy 2d polyline, lwpolyline, 3d polyline, helix, leader... Only thing is that blocks have to follow above mentioned rule of positioning and its attribute tag description... Quote Link to comment Share on other sites More sharing options...
Guest Posted September 16, 2013 Share Posted September 16, 2013 Ok this lisp is fine for me . Thank you for your time and for the help 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.