;;; Draw Road Chainage
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-changing-to-station-from-chainage/td-p/7914389

(defun div-error (msg)
(if
(vl-position
msg
'("console break"
"Function cancelled"
"quit / exit abort"
)
)
(princ "Error!")
(princ msg)
)
(while (> (getvar "cmdactive") 0) (command))
;;; (command "._undo" "_end")
;;; (command "._u")
(setq *error* olderror)
(princ)
)

(defun divplus (len segm / num lst)
(setq num (fix (/ len segm)))
(setq cnt 0)
(while (= len 0.)
(setq lst (append lst (list len)))
(setq len (- len segm))
)
(if (not (zerop (last lst)))
(setq lst (append lst (list 0.0)))
)
lst
)

(defun alg-ang (obj pnt)
(angle '(0. 0. 0.)
(vlax-curve-getfirstderiv
obj
(vlax-curve-getparamatpoint
obj
pnt
)
)
)
)

(defun answer (quest / wshl ans)
(or (vl-load-com))
(setq wshl (vlax-get-or-create-object "WScript.Shell"))
(setq ans (vlax-invoke-method
wshl
'Popup quest 7 "Answer This Question:" vlax-vbYesNo))
(vlax-release-object wshl)
(cond ((= ans 6)
(setq opt T))
((= ans 7)
(setq opt nil))
)
opt
)

(defun make-station (bname / acsp adoc atprom attag at_obj
blk_obj hgt lay line_obj sfar )

(vl-load-com)
(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)

(if (not (tblsearch "block" bname))
(progn
(setq attag "NUMBER" ;(strcase (getstring "\nAttribute tag : \n"))
atprom "NUMBER" ;(strcase (getstring T "\nAttribute prompt : \n"))
hgt 1.0 ;(getreal "\nAttribute text height : \n")
)

(setq lay (getvar "clayer"))
(setvar "clayer" "0")
(setvar "attreq" 0)

(setq line_obj (vlax-invoke acsp 'Addline '(0. 0. 0.) (list 0. (* hgt 12.) 0.)))
(vla-put-color line_obj acred)
(setq blk_obj (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) bname)
sfar (vlax-safearray-fill
(vlax-make-safearray vlax-vbObject '(0 . 0))
(list line_obj)
)
)
(vla-copyobjects adoc sfar blk_obj)
;;; RetVal = object.AddAttribute(Height, Mode, Prompt, InsertionPoint, Tag, Value)
(setq at_obj (vla-addattribute blk_obj
hgt
acattributemodeverify
atprom
(vlax-3d-point '(-0.5 1. 0.))
attag
"0+00")
)
;;; (vla-put-alignment at_obj acAlignmentBottomCenter)
;;; (vla-put-textalignmentpoint
;;; at_obj
;;; (vlax-3d-point '(0. 1. 0.))
;;; )
(vla-put-rotation at_obj (/ pi 2))
(vlax-release-object blk_obj)
)
(progn
(princ "\n\t >> Block does already exist!\n")
(princ)))
(if (tblsearch "block" bname)
T
(progn
(alert "Impossible to add block")))
(setvar "attreq" 1)
(setvar "clayer" lay)
(vl-catch-all-apply (function (lambda ()(vla-delete line_obj))))
(vla-regen adoc acactiveviewport)
(vla-endundomark adoc)
(vlax-release-object acsp)
(vlax-release-object adoc)
(princ)
)

(or (vl-load-com))
(defun C:dc (/ *error* acsp adoc appd div-error
len num olderror pl pt pt_list
step util
)

(or adoc
(setq adoc
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(or appd (setq appd (vla-get-application adoc)))
(or acsp
(setq acsp
(vla-get-block
(vla-get-activelayout adoc)
)
)
)
(or util (setq util (vla-get-utility adoc)))
;;; (command "._undo" "_end")
;;; (command "._undo" "_mark")
(setq olderror *error*)
(setq *error* div-error)
;;; (setq bname (getstring T "\nStation block name : \n"))
;;; (make-station bname)
(if (not (tblsearch "block" "Station"))
(make-station "Station"))

(vla-getentity
util
'pl
'pt
"\nSelect line NEAR OF POINT TO START measure: >>> \n"
)
(if pl
(progn
(setq step (getreal "\nEnter step for stationing : \n"))
(setq opt (answer "Rotate text perpendicularly to pline?"))
(if (not step)(setq step 10.))

(setq len (vlax-curve-getdistatparam
pl
(vlax-curve-getendparam pl)
)
)

(if (list pt)
(vlax-curve-getstartpoint pl)
)
(distance (vlax-safearray->list pt)
(vlax-curve-getendpoint pl)
)
)
(setq pt_list (divplus len step))
(setq pt_list (divminus len step))
)

(setq
pt_list (vl-remove-if
(function not)
(mapcar (function (lambda (x)
(vlax-curve-getpointatdist pl x)
)
)
pt_list
)
)
)

(setq num 0)
;;; (setq num (getint "\nEnter initial station number\n"))
(mapcar
(function
(lambda (x / dr ang att_list at blk_obj)
(progn

(setq ang (alg-ang pl x)
ang
(cond ((< (/ pi 2) ang (* pi 1.5)) (+ pi ang))
(T ang)
)
)
(setq blk_obj (vlax-invoke
acsp 'Insertblock x "Station" 1 1 1 ang)
)
(setq att_list (vlax-invoke blk_obj 'Getattributes))
(foreach at att_list
(if (eq (vlax-get at 'Tagstring) "NUMBER")
(progn
(vlax-put at 'Textstring (if (< num 990.)
(strcat "CH: 0+" (rtos num 2 2))
(strcat "CH: "
(itoa (fix (/ num 1000.)));<--- changes 1200. on num (typo)
"+"
(rtos (- num (* (fix (/ num 1000.)) 1000)) 2 2)
)
))
(if (not opt)
(vlax-put at 'Rotation 0))
(vla-update at)
)
)
)
(vla-update blk_obj)
(vlax-release-object blk_obj)
(setq num (+ num step))
)
)
)
pt_list
)

(if (not (vlax-object-released-p pl))
(vlax-release-object pl)
)
)
(princ "\nNothing selected try again\n")
)
(vla-zoomextents appd)
(vla-regen adoc acactiveviewport)
(setq *error* olderror
div-error nil
)
;;; (command "._undo" "_end")
(princ)
)
(prompt "\n")
(prompt "\n *** Type DC to execute *** \n")
(princ)
(c:dc)

Advertisements