Jump to content

insert distance between two points along a polyline


Guest

Recommended Posts

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

Link to comment
Share on other sites

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 by marko_ribar
replaced (while (setq att (entnext att)).) to (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND")).)
Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 ..

Link to comment
Share on other sites

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)
 )

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 by marko_ribar
replaced (while (setq att (entnext att)).) to (while (not (eq (cdr (assoc 0 (entget (setq att (entnext att))))) "SEQEND")).)
Link to comment
Share on other sites

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

Link to comment
Share on other sites

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.

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 !!

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 ?

Link to comment
Share on other sites

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...

Link to comment
Share on other sites

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.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...