Topic: draw chainage on polyline-HELP WITH A LISP

[pedroantonio]

Hi am using this code to add chanage to a a polyline but i need to do some changes
1) the chainage block to have 2 layers .One for the line and one for the text (Text color white ,line color 90)
2) convert chainage block  to Annotative with text paper size 2.5
3)Fix the last chainage of the polyline because is wrong

Code - Auto/Visual Lisp: [Select]

1. (defun div-error (msg)
2.  (if (vl-position msg '("console break" "Function cancelled" "quit / exit abort"))
3.    (princ "Error!")
4.    (princ msg)
5.  )
6.  (while (> (getvar "cmdactive") 0) (command))
7.  (setq *error* olderror)
8.  (princ)
9. )
10.  
11. (defun divplus (len segm / num lst)
12.  (setq num (fix (/ len segm)))
13.  (setq cnt 0)
14.  (while (<= cnt num)
15.    (setq tmp (* cnt segm))
16.    (setq lst (append lst (list tmp)))
17.    (setq cnt (1+ cnt))
18.  )
19.  (setq delta (- len (last lst)))
20.  (if (not (zerop delta))
21.    (setq lst (append lst (list (+ (last lst) delta))))
22.    lst
23.  )
24. )
25.  
26. (defun divminus (len segm / lst)
27.  (while (>= len 0.) (setq lst (append lst (list len))) (setq len (- len segm)))
28.  (if (not (zerop (last lst)))
29.    (setq lst (append lst (list 0.0)))
30.  )
31.  lst
32. )
33.  
34. (defun alg-ang (obj pnt)
35.  (angle '(0. 0. 0.) (vlax-curve-getfirstderiv obj (vlax-curve-getparamatpoint obj pnt)))
36. )
37.  
38. (defun answer (quest / wshl ans)
39.  (or (vl-load-com))
40.  (setq wshl (vlax-get-or-create-object "WScript.Shell"))
41.  (setq ans (vlax-invoke-method wshl 'popup quest 7 "Answer This Question:" vlax-vbyesno))
42.  (vlax-release-object wshl)
43.  (cond  ((= ans 6) (setq opt t))
44. ((= ans 7) (setq opt nil))
45.  )
46.  opt
47. )
48.  
49.  
50. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51. (defun make-station (bname / acsp adoc atprom attag at_obj blk_obj hgt lay line_obj sfar)
52.  (vl-load-com)
53.  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
54.  (if (and (= (getvar "tilemode") 0) (= (getvar "cvport") 1))
55.    (setq acsp (vla-get-paperspace adoc))
56.    (setq acsp (vla-get-modelspace adoc))
57.  )
58.  (vla-startundomark adoc)
59.  (if (not (tblsearch "block" bname))
60.    (progn (setq attag   "NUMBER"        ;(strcase (getstring "\nAttribute tag : \n"))
61.          atprom "NUMBER"        ;(strcase (getstring T "\nAttribute prompt : \n"))
62.          hgt    1.0             ;(getreal "\nAttribute text height : \n")
63.    )
64.    (setq lay (getvar "clayer"))
65.    (setvar "clayer" "0")
66.    (setvar "attreq" 0)
67.    (setq line_obj (vlax-invoke acsp 'addline '(0. -3. 0.) (list 0. (* hgt 2.) 0.)))
68.    (vla-put-color line_obj acred)
69.    (setq blk_obj (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) bname)
70.          sfar    (vlax-safearray-fill (vlax-make-safearray vlax-vbobject '(0 . 0)) (list line_obj))
71.    )
72.    (vla-copyobjects adoc sfar blk_obj)
73. ;;;  RetVal = object.AddAttribute(Height, Mode, Prompt, InsertionPoint, Tag, Value)
74.    (setq at_obj (vla-addattribute
75.                   blk_obj
76.                   hgt
77.                   acattributemodeverify
78.                   atprom
79.                   (vlax-3d-point '(0 10. 0.))
80.                   attag
81.                   "0"
82.                 )
83.    )
84.    (vla-put-rotation at_obj (* pi 1.5))
85.    (vlax-release-object blk_obj)
86.    )
87.    (progn (princ "\n\t >> Block does already exist!\n") (princ))
88.  )
89.  (if (tblsearch "block" bname)
90.    t
91.    (progn (alert "Impossible to add block"))
92.  )
93.  (setvar "attreq" 1)
94.  (setvar "clayer" lay)
95.  (vl-catch-all-apply (function (lambda () (vla-delete line_obj))))
96.  (vla-regen adoc acactiveviewport)
97.  (vla-endundomark adoc)
98.  (vlax-release-object acsp)
99.  (vlax-release-object adoc)
100.  (princ)
101. )
102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103. (or (vl-load-com))
104. (defun c:chg (/ *error* acsp adoc appd div-error len num olderror pl pt pt_list step util)
105.  (or adoc (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
106.  (or appd (setq appd (vla-get-application adoc)))
107.  (or acsp (setq acsp (vla-get-block (vla-get-activelayout adoc))))
108.  (or util (setq util (vla-get-utility adoc)))
109.  (setq olderror *error*)
110.  (setq *error* div-error)
111.  (if (not (tblsearch "block" "Station"))
112.    (make-station "Station")
113.  )
114.  (vla-getentity util 'pl 'pt "\nSelect line NEAR OF POINT TO START measure: >>> \n")
115.  (if (and pl (or (setq step (getdist "\Enter step distance [<10>]: ")) (setq step 10)))
116.    (progn
117.      
118.      (setq opt (answer "Rotate text perpendicularly to pline?"))
119.      (if (not step)
120. (setq step 10.)
121.      )
122.      (setq len (vlax-curve-getdistatparam pl (vlax-curve-getendparam pl)))
123.      (if (< (distance (vlax-safearray->list pt) (vlax-curve-getstartpoint pl))
124.      (distance (vlax-safearray->list pt) (vlax-curve-getendpoint pl))
125.   )
126. (setq pt_list (divplus len step))
127. (setq pt_list (divminus len step))
128.      )
129.      (setq pt_list (vl-remove-if
130.               (function not)
131.               (mapcar (function (lambda (x) (vlax-curve-getpointatdist pl x))) pt_list)
132.             )
133.      )
134.      (setq num 0)
135.      (mapcar
136. (function
137.   (lambda (x / dr ang att_list at blk_obj)
138.     (progn
139.       (setq ang (alg-ang pl x)
140.             ang (cond ((< (/ pi 2) ang (* pi 1.5)) (+ pi ang))
141.                       (t ang)
142.                 )
143.       )
144.       (setq blk_obj (vlax-invoke acsp 'insertblock x "Station" 1 1 1 ang))
145.       (setq att_list (vlax-invoke blk_obj 'getattributes))
146.       (foreach at att_list
147.         (if (eq (vlax-get at 'tagstring) "NUMBER")
148.           (progn (vlax-put at 'textstring (strcat "ch: " (rtos num 2 2) " m"))
149.                  (if (not opt)
150.                    (vlax-put at 'rotation 0)
151.                  )
152.                  (vla-update at)
153.           )
154.         )
155.       )
156.       (vla-update blk_obj)
157.       (vlax-release-object blk_obj)
158.       (setq num (+ num step))
159.     )
160.   )
161. )
162. pt_list
163.      )
164.      (if (not (vlax-object-released-p pl))
165. (vlax-release-object pl)
166.      )
167.    )
168.    (princ "\nNothing selected try again\n")
169.  )
170.  (vla-zoomextents appd)
171.  (vla-regen adoc acactiveviewport)
172.  (setq  *error* olderror
173. div-error nil
174.  )
175.  (princ)
176. )
177. (prompt "\n")
178. (prompt "\n    ***    Type chg to execute    *** \n")
179.  
180.  

thanks

[pedroantonio]

I uupdate the code but i need the changes from post 1

Code - Auto/Visual Lisp: [Select]

1. (defun div-error (msg)
2.  (if (vl-position msg '("console break" "Function cancelled" "quit / exit abort"))
3.    (princ "Error!")
4.    (princ msg)
5.  )
6.  (while (> (getvar "cmdactive") 0) (command))
7.  (setq *error* olderror)
8.  (princ)
9. )
10.  
11. (defun divplus (len segm / num lst)
12.  (setq num (fix (/ len segm)))
13.  (setq cnt 0)
14.  (while (<= cnt num)
15.    (setq tmp (* cnt segm))
16.    (setq lst (append lst (list tmp)))
17.    (setq cnt (1+ cnt))
18.  )
19.  (setq delta (- len (last lst)))
20.  (if (not (zerop delta))
21.    (setq lst (append lst (list (+ (last lst) delta))))
22.    lst
23.  )
24. )
25.  
26. (defun divminus (len segm / lst)
27.  (while (>= len 0.) (setq lst (append lst (list len))) (setq len (- len segm)))
28.  (if (not (zerop (last lst)))
29.    (setq lst (append lst (list 0.0)))
30.  )
31.  lst
32. )
33.  
34. (defun alg-ang (obj pnt)
35.  (angle '(0. 0. 0.) (vlax-curve-getfirstderiv obj (vlax-curve-getparamatpoint obj pnt)))
36. )
37.  
38. (defun answer (quest / wshl ans)
39.  (or (vl-load-com))
40.  (setq wshl (vlax-get-or-create-object "WScript.Shell"))
41.  (setq ans (vlax-invoke-method wshl 'popup quest 7 "Answer This Question:" vlax-vbyesno))
42.  (vlax-release-object wshl)
43.  (cond  ((= ans 6) (setq opt t))
44. ((= ans 7) (setq opt nil))
45.  )
46.  opt
47. )
48.  
49.  
50. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51. (defun make-station (bname / acsp adoc atprom attag at_obj blk_obj hgt lay line_obj sfar)
52.  (vl-load-com)
53.  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
54.  (if (and (= (getvar "tilemode") 0) (= (getvar "cvport") 1))
55.    (setq acsp (vla-get-paperspace adoc))
56.    (setq acsp (vla-get-modelspace adoc))
57.  )
58.  (vla-startundomark adoc)
59. (COMMAND "_layer" "_m" "_chg text" "_c" "7" "" "")
60.  (if (not (tblsearch "block" bname))
61.    (progn (setq attag   "NUMBER"        ;(strcase (getstring "\nAttribute tag : \n"))
62.          atprom "NUMBER"        ;(strcase (getstring T "\nAttribute prompt : \n"))
63.          hgt    1               ;(getreal "\nAttribute text height : \n")
64.    )
65.    (setq lay (getvar "clayer"))
66.    (setvar "clayer" "0")
67.    (setvar "attreq" 0)
68.    (setq line_obj (vlax-invoke acsp 'addline '(0. -1. 0.) (list 0. (* hgt 1.) 0.)))
69.    (vla-put-color line_obj acred)
70.    (setq blk_obj (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) bname)
71.          sfar    (vlax-safearray-fill (vlax-make-safearray vlax-vbobject '(0 . 0)) (list line_obj))
72.    )
73.    (vla-copyobjects adoc sfar blk_obj)
74. ;;;  RetVal = object.AddAttribute(Height, Mode, Prompt, InsertionPoint, Tag, Value)
75.    (setq at_obj (vla-addattribute
76.                   blk_obj
77.                   hgt
78.                   acattributemodeverify
79.                   atprom
80.                   (vlax-3d-point '(0 10. 0.))
81.                   attag
82.                   "0"
83.                 )
84.    )
85.    (vla-put-rotation at_obj (* pi 1.5))
86.    (vlax-release-object blk_obj)
87.    )
88.    (progn (princ "\n\t >> Block does already exist!\n") (princ))
89.  )
90.  (if (tblsearch "block" bname)
91.    t
92.    (progn (alert "Impossible to add block"))
93.  )
94.  (setvar "attreq" 1)
95.  (setvar "clayer" lay)
96.  (vl-catch-all-apply (function (lambda () (vla-delete line_obj))))
97.  (vla-regen adoc acactiveviewport)
98.  (vla-endundomark adoc)
99.  (vlax-release-object acsp)
100.  (vlax-release-object adoc)
101.  (princ)
102. )
103. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104. (or (vl-load-com))
105. (defun c:chg2 (/ *error* acsp adoc appd div-error len num olderror pl pt pt_list step util)
106.  (or adoc (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
107.  (or appd (setq appd (vla-get-application adoc)))
108.  (or acsp (setq acsp (vla-get-block (vla-get-activelayout adoc))))
109.  (or util (setq util (vla-get-utility adoc)))
110.  (setq olderror *error*)
111.  (setq *error* div-error)
112.  (if (not (tblsearch "block" "CHAINAGE"))
113.    (make-station "CHAINAGE")
114.  )
115.  (vla-getentity util 'pl 'pt "\nSelect line NEAR OF POINT TO START measure: >>> \n")
116.  (if (and pl (or (setq step (getdist "\Enter step distance [<10>]: ")) (setq step 10)))
117.    (progn
118.      
119.      (setq opt (answer "Rotate text perpendicularly to pline?"))
120.      (if (not step)
121. (setq step 10.)
122.      )
123.      (setq len (vlax-curve-getdistatparam pl (vlax-curve-getendparam pl)))
124.      (if (< (distance (vlax-safearray->list pt) (vlax-curve-getstartpoint pl))
125.      (distance (vlax-safearray->list pt) (vlax-curve-getendpoint pl))
126.   )
127. (setq pt_list (divplus len step))
128. (setq pt_list (divminus len step))
129.      )
130.      (setq pt_list (vl-remove-if
131.               (function not)
132.               (mapcar (function (lambda (x) (vlax-curve-getpointatdist pl x))) pt_list)
133.             )
134.      )
135.      (setq num 0)
136.      (mapcar
137. (function
138.   (lambda (x / dr ang att_list at blk_obj)
139.     (progn
140.       (setq ang (alg-ang pl x)
141.             ang (cond ((< (/ pi 2) ang (* pi 1.5)) (+ pi ang))
142.                       (t ang)
143.                 )
144.       )
145. (setq blk_obj (vlax-invoke
146.                   acsp 'Insertblock    x "CHAINAGE" 1 1 1 ang)
147.           )
148.           (setq att_list (vlax-invoke blk_obj 'Getattributes))
149.           (foreach at att_list
150.         (if (eq (vlax-get at 'Tagstring) "NUMBER")
151.           (progn
152.             (vlax-put at 'Textstring (if (< num 990.)
153.     (strcat "CH: 0+" (rtos num 2 2))
154. (strcat "CH: "
155.     (itoa (fix (/ num 1000.)));<--- changes 1200. on num (typo)
156.     "+"
157.     (rtos (- num (* (fix (/ num 1000.)) 1000)) 2 2))
158. ))
159.             (if (not opt)
160.             (vlax-put at 'Rotation 0))
161.             (vla-update at)
162.           )
163.         )
164.           )
165.           (vla-update blk_obj)
166.           (vlax-release-object blk_obj)
167.           (setq num (+ num step))
168.         )
169.       )
170.     )
171.     pt_list
172.      )
173.      (if (not (vlax-object-released-p pl))
174. (vlax-release-object pl)
175.      )
176.    )
177.    (princ "\nNothing selected try again\n")
178.  )
179.  (vla-zoomextents appd)
180.  (vla-regen adoc acactiveviewport)
181.  (setq  *error* olderror
182. div-error nil
183.  )
184.  (princ)
185. )
186. (prompt "\n")
187. (prompt "\n    ***    Type chg2 to execute    *** \n")
188.  
189.  

[pedroantonio]

I update the code , but i need help. My bigest problem is the last chainage text. Is not correct. Can any one fix it

Thanks

[Dlanor]

Having a copy of the block (autoCAD 2010) might help.

[pedroantonio]

Hi Dlanor.The lisp create the block

[pedroantonio]

I upload a dwg file to help you understand my question

[Dlanor]

Attached is the updated lisp.

When the block is created it is made annotative thanks to a little Lee Mac snippet I found [link is in file above the new (defun annotativeblock)].

The block now has two layers. The line is in layer 0 colour 90 The attribute is in layer "_chg text". I hope this is correct.

The Error on the last chainage was caused by the increment inside the mapcar exceeding the polyline length. I've added a check so that when num > len set num = len

Although the block is annotative I'm afraid I have no idea how to make it 2.5? in paperspace, perhaps someone else can step in as I have never worked with annotative blocks.

I have also tidied up a few lines of code. The layer is now only created if it doesn't exist.

[pedroantonio]

Thank you Dlanor. Can toy add a new layer for the green line with name "_chg line "?

[Dlanor]

Attached is updated lisp

[pedroantonio]

Thank you  Dlanor