Originally Posted by
jim.buhrdorf214720
It seems just crazy to me that nobody has a lisp routine that will station a polyline (in the standard 0+00 format) where you can pick a polyline in MODEL space (at scale 1:1), you don't have to screw around with scales, and it will draw stations and tic marks at desired distances. I use Map3D. Gone are the good old days when I used Survcadd. Is anybody out there working for a civil engineering firm?????
You may want to use this one from my oldies
Code:
;; written by Fatty T.O.H. ()2004 * all rights removed
;; edited 6/5/10
;; edited 6/10/10
;; Stationing
;;load ActiveX library
(vl-load-com)
;;local defuns
;//
(defun makeblock (adoc aprompt atag bname txtheight tstyle / at_obj blk_obj lay line_obj tst)
(if (not (tblsearch "block" bname))
(progn
(setq tst (getvar "textstyle"))
(setvar "textstyle" tstyle)
(setq lay (getvar "clayer"))
(setvar "clayer" "0")
(setq blk_obj (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) bname))
(setq line_obj (vlax-invoke blk_obj 'Addline '(0. 0. 0.) (list 0. 12.0 0.)))
(vla-put-color line_obj acyellow)
(setq at_obj (vla-addattribute blk_obj
txtheight
acattributemodeverify
aprompt
(vlax-3d-point '(-0.5 1. 0.))
atag
"0+00")
)
(vla-put-rotation at_obj (/ pi 2))
(vla-put-color at_obj acwhite)
(mapcar (function (lambda(x) vlax-release-object x))
(list at_obj line_obj blk_obj )
)
(setvar "clayer" lay)
(setvar "textstyle" tst)
)
)
)
;;//
(defun start (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getstartpoint curve
)
)
)
)
)
)
;;//
(defun end (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getendpoint curve
)
)
)
)
)
)
;;//
(defun pointoncurve (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
pt
)
)
)
)
)
;;//
(defun paramatpoint (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getparamatpoint curve
pt
)
)
)
)
)
;;//
(defun distatpt (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatpoint curve
(vlax-curve-getclosestpointto curve pt)
)
)
)
)
)
;;//
(defun pointatdist (curve dist)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getpointatdist curve dist)
)
)
)
)
)
;;//
(defun curvelength (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatparam curve
(- (vlax-curve-getendparam curve)
(vlax-curve-getstartparam curve)
)
)
)
)
)
)
;;//
(defun distatparam (curve param)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatparam curve
param
)
)
)
)
)
;;//
(defun statlabel (num step div)
;; num - integer, zero based
;; step - double or integer, must be non zero
(strcat
(itoa (fix (/ num div)))
"+"
(if (zerop (rem num div))
"00"
(rtos (* (rem num div) step) 2 0))
)
)
;;//
(defun insertstation (acsp bname pt rot tag num step div / block)
(vl-catch-all-apply
(function (lambda()
(setq block (vlax-invoke-method acsp 'InsertBlock pt bname 1 1 1 rot))
)
)
)
(changeatt block tag (statlabel num step div))
block
)
;;//
(defun changeatt (block tag value / att)
(setq atts (vlax-invoke block 'GetAttributes))
(foreach att atts
(if (equal tag (vla-get-tagstring att))
(vla-put-textstring att value)
)
)
)
;;// written by VovKa (Vladimir Kleshev)
(defun gettangent (curve pt)
(setq param (paramatpoint curve pt)
ang ((lambda (deriv)
(if (zerop (cadr deriv))
(/ pi 2)
(atan (apply '/ deriv))
)
)
(cdr (reverse
(vlax-curve-getfirstderiv curve param)
)
)
)
)
ang
)
;;// main program
(defun c:STAN (/ *error* acsp adoc block cnt div en ent label
lastp lay leng lnum mul num pt rot sign start step)
(defun *error* (msg)
(if msg (princ (strcat "\nError! " msg)))
(princ)
)
(setvar "dimzin" 4)
(setq lay (getvar "clayer"))
(setvar "clayer" "0")
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
acsp (vla-get-block (vla-get-activelayout adoc))
)
(if (not (tblsearch "block" "Station"))
(makeblock adoc "NUMBER" "NUMBER" "Station" 2.0 "Standard")
)
(while (not
(and
(or
(initget 6)
(setq step (getreal "\nEnter step <25>: "))
(if (not step)
(setq step 25.)))
(zerop (rem 100 step))))
(alert (strcat "\nRemainder 100 / " (rtos step 2 2) " is not equal to zero
\nEnter correct step"))
)
(if
(setq
ent (entsel
"\nSelect curve near to the start point >>"
)
)
(progn
(setq en (car ent)
pt (pointoncurve en (cadr ent))
leng (distatparam en (vlax-curve-getendparam en))
)
(setq num (fix (/ leng step))
)
(setq div (fix (/ 100. step)
)
)
(setq mul (- leng
(* (setq lnum (fix (/ leng (* step div)))) (* step div))))
(if (not (zerop mul))
(setq lastp T)
(setq lastp nil)
)
(if (> (- (paramatpoint en pt)
(paramatpoint en (vlax-curve-getstartpoint en))
)
(- (paramatpoint en (vlax-curve-getendpoint en))
(paramatpoint en pt)
)
)
(progn
(setq start leng
sign -1
)
)
(progn
(setq start (distatparam en (vlax-curve-getstartparam en))
sign 1
)
)
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(setq cnt 0)
(repeat (1+ num)
(setq pt (pointatdist en start)
rot (gettangent en pt)
)
(setq block
(insertstation
acsp
"Station"
(vlax-3d-point pt)
rot
"NUMBER"
cnt
step
div)
)
(setq cnt (1+ cnt)
start (+ start (* sign step))
)
)
(if lastp
(progn
(if (= sign -1)
(progn
(setq pt (vlax-curve-getstartpoint en)
rot (gettangent en pt)
)
)
(progn
(setq pt (vlax-curve-getendpoint en)
rot (gettangent en pt)
)
)
)
(setq block
(insertstation
acsp
"Station"
(vlax-3d-point pt)
rot
"NUMBER"
(1- cnt)
0
div)
)
(setq label (strcat (itoa lnum) "+" (rtos mul 2 2))
)
(changeatt block "NUMBER" label)
)
)
(setvar "clayer" lay)
(vla-endundomark
(vla-get-activedocument (vlax-get-acad-object))
)
)
(princ "\nNothing selected")
)
(*error* nil)
(princ)
)
(prompt "\n >>> Type STAN to execute...")
(prin1)
~'J'~
Re: Stationing Autolisp routine
Posting Permissions
Reply With Quote