Code:
(SETVAR "LUPREC" 4)
(SETVAR "LUNITS" 2)
(setq ce (getvar "cmdecho"))
(setvar 'CMDECHO 0)
(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 (<= cnt num)
(setq tmp (* cnt segm))
(setq lst (append lst (list tmp)))
(setq cnt (1+ cnt))
)
(setq delta (- len (last lst)))
(if (not (zerop delta))
(setq lst (append lst (list (+ (last lst) delta))))
lst
)
)
(defun divminus (len segm / lst)
(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 acyellow)
(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:d10 (/ *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 <10> : \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 (< (distance (vlax-safearray->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 10.)
(strcat "00+00" (rtos num 2 2))
(if (< num 100.)
(strcat "00+0" (rtos num 2 2))
(if (< num 1000.)
(strcat "00+" (rtos num 2 2))
(if (< num 10000.)
(strcat "0" (itoa (fix (/ num 1000.)))"+"
(if(< (- num (* (fix (/ num 1000.)) 1000))
10)
(strcat "00" (rtos (- num(* (fix (/ num 1000.)) 1000)) 2 2 ))
(if
(< (- num(* (fix (/ num 1000.)) 1000))100)
(strcat "0"(rtos(- num(* (fix (/ num 1000.)) 1000)) 2 2 ))
(rtos (- num(* (fix (/ num 1000.)) 1000)) 2 2)
)
)
) ;stracat
(if (< num 100000.)
(strcat "" (itoa (fix (/ num 1000.)))"+"
(if
(< (- num(* (fix (/ num 1000.)) 1000))
10)
(strcat "00" (rtos(- num(* (fix (/ num 1000.)) 1000)) 2 2))
(if
(< (- num(* (fix (/ num 1000.)) 1000))100)
(strcat"0"(rtos(- num(* (fix (/ num 1000.)) 1000)) 2 2))
(rtos(- num(* (fix (/ num 1000.)) 1000)) 2 2)
)
)
) ;stracat
(strcat ""(itoa (fix (/ num 1000.)))"+"
(if
(< (- num(* (fix (/ num 1000.)) 1000))10)
(strcat"00"(rtos(- num(* (fix (/ num 1000.)) 1000))2 2))
(if
(< (- num(* (fix (/ num 1000.)) 1000))100
)
(strcat"0"(rtos(- num(* (fix (/ num 1000.)) 1000))2 2))
(rtos(- num(* (fix (/ num 1000.)) 1000)) 2 2)
)
)
) ;stracat
)
)
)
)
) ;if
) ;vlaxput
(if (not opt)
(vlax-put at 'Rotation 0)
) ;if
(vla-update at)
) ; progn
) ;if
) ;foreach
(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)
(setvar "cmdecho" ce)
)
(prompt "\n")
(prompt "\n *** Type D10 to execute *** \n")
(princ)