PDA

View Full Version : Stationing Autolisp routine



aaronic_abacus
2007-01-03, 02:22 AM
Here's a stationing autolisp routine I created before learning SoftDESK(land desktop).
(see attachments)



(DEFUN C:SM (/ LP BP LOP LUP SLPS SLEN SLPP SLNPP SLEPP SLLA SLL CL SL NO SMN XS EV1 EVS SV EV2 PEP1 PEP2 FIP MARK NMSS DBO ISMN DBF LOOP IP RA PM SMSP SMSS SMS JC1 JC2 JS FLTR)
(SETQ DBO 0)
(SETQ ISMN 0)
(SETQ NO NIL)
(PROMPT "*STATION MARK*")
(SETQ LP 1)
(WHILE LP
(SETQ BP (GETPOINT "\nPick first station location: "))
(SETQ BP (OSNAP BP "NEA"))
(IF (/= BP NIL)
(SETQ LP NIL)
(PROMPT " POINT NOT ON STATION LINE ")
)
);END WHILE LP
(SETQ LUP 1)
(WHILE LUP
(SETQ LOP 1)
(WHILE LOP
(SETQ SLPS (ENTSEL "\nSelect station line: "))
(IF (/= SLPS NIL)
(SETQ LOP NIL)
(PROMPT " NO OBJECT SELECTED ")
)
);END WHILE LOP
(SETQ SLEN (CAR SLPS))
(IF (= (CDR (ASSOC 0 (ENTGET SLEN))) "LWPOLYLINE")
(SETQ LUP NIL)
(PROMPT " OBJECT SELECTED NOT A POLYLINE ")
)
);END WHILE LUP
(SETQ SLPP (CADR SLPS))
(SETQ SLNPP (OSNAP SLPP "NEA"))
(COMMAND "BREAK" SLNPP "F" BP BP)
(SETQ SLEN (SSNAME (SSGET SLNPP) 0))
(SETQ SLLA (ASSOC 8 (ENTGET SLEN)))
(SETQ SLL (CDR SLLA))
(SETQ CL (GETVAR "CLAYER"))
(SETVAR "CLAYER" SLL)
(SETQ SMN (GETREAL "\nStarting station mark # <0>: "))
(IF (= SMN NIL)
(SETQ SMN 0)
)
(INITGET "A D")
(SETQ NO (GETKWORD "\nDescend <Ascend>: "))
(IF (= NO NIL)
(SETQ NO "A")
)
(SETQ SL (GETREAL "\nStation segment length <50>: "))
(IF (= SL NIL)
(SETQ SL 50.0)
)
(PROMPT "\nSymbol scale <")
(PRINC DWGSCALE)
(PROMPT ">: ")
(SETQ XS (GETREAL))
(IF (= XS NIL)
(SETQ XS DWGSCALE)
)

(SETQ SLENL (ENTGET SLEN))
(SETQ EV1 (CDR (ASSOC 10 SLENL)))
(SETQ EVS EV1)
(SETQ SV 1)
(WHILE SV
(SETQ SLENL (CDR SLENL))
(SETQ EVT (ASSOC 10 SLENL))
(IF (/= EVT NIL)
(SETQ EV2 (CDR EVT))
(SETQ SV NIL)
)
);END WHILE SV
(SETQ PEP1 EV1)
(SETQ PEP2 EV2)
(IF (> (DISTANCE SLNPP PEP2) (DISTANCE SLNPP PEP1))
(SETQ FIP PEP1)
(SETQ FIP PEP2)
)

(COMMAND "INSERT" "MARK" FIP XS "" SLNPP)
(SETQ MARK (ENTLAST))
(COMMAND "REGENAUTO" "OFF")
(COMMAND "MEASURE" SLNPP "B" "MARK" "Y" (* SL 12))
(SETQ NMSS (SSLENGTH (SSGET "P")))
(IF (> (DISTANCE FIP (CDR (ASSOC 10 (ENTGET (ENTNEXT MARK)))))
(+ (* SL 12) 1)
)
(PROGN (SETQ DBO 1) (SETQ ISMN 1))
(SETQ DBO 0)
)
(COMMAND "POINT" "@")
(SETQ DBF (ENTLAST))
(COMMAND "SETVAR" "ATTREQ" "0")
(SETQ LOOP 1)
(WHILE LOOP
(SETQ ELIST (ENTGET MARK))
(SETQ IP (CDR (ASSOC 10 ELIST)))
(SETQ RA (/ (* 180 (CDR (ASSOC 50 ELIST))) PI))
(SETQ RA (- RA (* (FIX (/ RA 360)) 360)))
(IF (AND (> RA 90) (< RA 270))
(SETQ RA (+ RA 180))
)
(SETQ PM MARK)
(SETQ MARK (ENTNEXT MARK))
(COMMAND "ERASE" PM "")
(COMMAND "INSERT" "STMK" IP XS "" RA)
(SETQ SMSP (FIX (/ SMN 100)))
(SETQ SMSS (- SMN (* SMSP 100)))
(IF (< SMSP 0)
(SETQ SMSP (* -1 SMSP))
)
(IF (< SMSS 0)
(SETQ SMSS (* -1 SMSS))
)
(IF (= SMSS 0)
(SETQ SMSS "00")
(SETQ SMSS (RTOS SMSS 2 0))
)
(SETQ SMSP (RTOS SMSP 2 0))
(SETQ SMS (STRCAT SMSP "+" SMSS))
(COMMAND "ATTEDIT" "N" "N" "STMK" "STMK" "STMK" "STMK" SMS)
(IF (AND (= ISMN 1) (= NO "A"))
(PROGN (SETQ SMN (+ (+ (* NMSS SL) SMN) SL)) (SETQ ISMN 0))
)
(IF (AND (= ISMN 1) (= NO "D"))
(PROGN (SETQ SMN (- SMN (+ (* NMSS SL) SL))) (SETQ ISMN 0))
)
(IF (AND (= DBO 1) (= NO "A"))
(SETQ SMN (- SMN SL))
)
(IF (AND (= DBO 0) (= NO "A"))
(SETQ SMN (+ SMN SL))
)
(IF (AND (= DBO 1) (= NO "D"))
(SETQ SMN (+ SMN SL))
)
(IF (AND (= DBO 0) (= NO "D"))
(SETQ SMN (- SMN SL))
)
(IF (= (CDR (ASSOC 0 (ENTGET MARK))) "POINT")
(SETQ LOOP NIL)
)
);END WHILE
(SETQ JC1 (MAPCAR '+ BP '(0.01 0.01 0.0)))
(SETQ JC2 (MAPCAR '- BP '(0.01 0.01 0.0)))

(SETQ
FLTR (LIST '(-4 . "<AND") SLLA '(0 . "POLYLINE") '(-4 . "AND>"))
)
(SETQ JS (SSGET "C" JC1 JC2 FLTR))
(COMMAND "PEDIT" SLEN "J" JS "" "X")
(COMMAND "SETVAR" "ATTREQ" "1")
(COMMAND "REGENAUTO" "ON")
(COMMAND "ERASE" DBF "")
(SETVAR "CLAYER" CL)
(PRINC)
);END SM[ Moderator Action = ON ] What are [ CODE ] tags... (http://forums.augi.com/misc.php?do=bbcode#code) [ Moderator Action = OFF ]

robertlynch
2010-03-03, 04:47 PM
Could you give me some instructions on how to use this lisp? Im using ACAD2008 with no add-ons. I loaded the routine files but cannot get it to work.

Thanks

RobertB
2010-03-03, 05:25 PM
Could you give me some instructions on how to use this lisp? Im using ACAD2008 with no add-ons. I loaded the routine files but cannot get it to work. It helps when you mention what errors you see.

Are the drawings Mark and StMk located in a folder somewhere in AutoCAD's support path or the current drawing's folder?

robertlynch
2010-03-03, 05:27 PM
Im not seeing any error messages. What is the command to envoke the lisp?
(all files are in the same spot, i believe they're in the right spot)

aaronic_abacus
2010-03-03, 10:41 PM
First use SDS to set the drawing scale,
then SM to station the the polyline.

jeremyburt76
2010-08-19, 03:06 PM
Anyway to make this work for a 3D Poly?

aaronic_abacus
2010-08-21, 12:55 AM
; This version will work with 3DPOLYs




(DEFUN C:SM (/ LP BP LOP LUP SLPS SLEN SLPP SLNPP SLEPP SLLA SLL CL SL NO SMN XS EV1 EVS SV EV2 PEP1 PEP2 FIP MARK NMSS DBO ISMN DBF LOOP IP RA PM SMSP SMSS SMS JC1 JC2 JS FLTR)
(SETVAR "LUNITS" 3)
(SETQ DBO 0)
(SETQ ISMN 0)
(SETQ NO NIL)
(PROMPT "*STATION MARK*")
(SETQ LP 1)
(WHILE LP
(SETQ BP (GETPOINT "\nPick first station location: "))
(SETQ BP (OSNAP BP "NEA"))
(IF (/= BP NIL) (SETQ LP NIL) (PROMPT " POINT NOT ON STATION LINE "))
);END WHILE LP
(SETQ LUP 1)
(WHILE LUP
(SETQ LOP 1)
(WHILE LOP
(SETQ SLPS (ENTSEL "\nSelect station line: "))
(IF (/= SLPS NIL) (SETQ LOP NIL) (PROMPT " NO OBJECT SELECTED "))
);END WHILE LOP
(SETQ SLEN (CAR SLPS))
(IF (OR (= (CDR(ASSOC 0 (ENTGET SLEN))) "LWPOLYLINE") (= (CDR(ASSOC 0 (ENTGET SLEN))) "POLYLINE")) (SETQ LUP NIL) (PROMPT " OBJECT SELECTED NOT A POLYLINE "))
);END WHILE LUP
(SETQ SLPP (CADR SLPS))
(SETQ SLNPP (OSNAP SLPP "NEA"))
(COMMAND "BREAK" SLNPP "F" BP BP)
(SETQ SLEN (SSNAME (SSGET SLNPP) 0))
(SETQ SLLA (ASSOC 8 (ENTGET SLEN)))
(SETQ SLL (CDR SLLA))
(SETQ CL (GETVAR "CLAYER"))
(SETVAR "CLAYER" SLL)
(SETQ SMN (GETREAL "\nStarting station mark # <0>: "))
(IF (= SMN NIL) (SETQ SMN 0))
(INITGET "A D")
(SETQ NO (GETKWORD "\nDescend <Ascend>: "))
(IF (= NO NIL) (SETQ NO "A"))
(SETQ SL (GETREAL "\nStation segment length <50>: "))
(IF (= SL NIL) (SETQ SL 50.0))
(PROMPT "\nSymbol scale <")
(PRINC DWGSCALE )
(PROMPT ">: ")
(SETQ XS (GETREAL))
(IF (= XS NIL) (SETQ XS DWGSCALE))

(SETQ SLENL (ENTGET SLEN))
(SETQ EV1 (CDR(ASSOC 10 SLENL)))
(SETQ EVS EV1)
(SETQ SV 1)
(WHILE SV
(SETQ SLENL (CDR SLENL))
(SETQ EVT (ASSOC 10 SLENL))
(IF (/= EVT NIL) (SETQ EV2 (CDR EVT)) (SETQ SV NIL))
);END WHILE SV
(SETQ PEP1 EV1)
(SETQ PEP2 EV2)
(IF (> (DISTANCE SLNPP PEP2) (DISTANCE SLNPP PEP1)) (SETQ FIP PEP1) (SETQ FIP PEP2))

(COMMAND "INSERT" "MARK" FIP XS "" SLNPP)
(SETQ MARK (ENTLAST))
(COMMAND "REGENAUTO" "OFF")
(COMMAND "MEASURE" SLNPP "B" "MARK" "Y" (* SL 12))
(SETQ NMSS (SSLENGTH (SSGET "P")))
(IF (> (DISTANCE FIP (CDR(ASSOC 10(ENTGET MARK)))) SL) (PROGN (SETQ DBO 1) (SETQ ISMN 1)) (SETQ DBO 0))
(COMMAND "POINT" "@")
(SETQ DBF (ENTLAST))
(COMMAND "SETVAR" "ATTREQ" "0")
(SETQ LOOP 1)
(WHILE LOOP
(SETQ ELIST (ENTGET MARK))
(SETQ IP (CDR(ASSOC 10 ELIST)))
(SETQ RA (/ (* 180 (CDR(ASSOC 50 ELIST))) PI))
(SETQ RA (- RA (* (FIX (/ RA 360)) 360)))
(IF (AND (> RA 90) (< RA 270)) (SETQ RA (+ RA 180)))
(SETQ PM MARK)
(SETQ MARK (ENTNEXT MARK))
(COMMAND "ERASE" PM "")
(COMMAND "INSERT" "STMK" IP XS "" RA)
(SETQ SMSP (FIX (/ SMN 100)))
(SETQ SMSS (- SMN (* SMSP 100)))
(IF (< SMSP 0) (SETQ SMSP (* -1 SMSP)))
(IF (< SMSS 0) (SETQ SMSS (* -1 SMSS)))
(IF (= SMSS 0) (SETQ SMSS "00") (SETQ SMSS (RTOS SMSS 2 0)))
(SETQ SMSP (RTOS SMSP 2 0))
(SETQ SMS (STRCAT SMSP "+" SMSS ))
(COMMAND "ATTEDIT" "N" "N" "STMK" "STMK" "STMK" "STMK" SMS)
(IF (AND (= ISMN 1) (= NO "A")) (PROGN (SETQ SMN (+ (+ (* NMSS SL) SMN) SL)) (SETQ ISMN 0)))
(IF (AND (= ISMN 1) (= NO "D")) (PROGN (SETQ SMN (- SMN (+ (* NMSS SL) SL))) (SETQ ISMN 0)))
(IF (AND (= DBO 1) (= NO "A")) (SETQ SMN (- SMN SL)))
(IF (AND (= DBO 0) (= NO "A")) (SETQ SMN (+ SMN SL)))
(IF (AND (= DBO 1) (= NO "D")) (SETQ SMN (+ SMN SL)))
(IF (AND (= DBO 0) (= NO "D")) (SETQ SMN (- SMN SL)))
(IF (= (CDR(ASSOC 0 (ENTGET MARK))) "POINT") (SETQ LOOP NIL))
);END WHILE
(SETQ JC1 (MAPCAR '+ BP '(0.01 0.01 0.0) ))
(SETQ JC2 (MAPCAR '- BP '(0.01 0.01 0.0) ))

;(SETQ FLTR (LIST '(-4 . "<AND") SLLA '(0 . "LWPOLYLINE") '(-4 . "AND>")))
;(SETQ JS (SSGET "C" JC1 JC2 FLTR))
;(COMMAND "PEDIT" SLEN "J" JS "" "X")
(COMMAND "SETVAR" "ATTREQ" "1")
(COMMAND "REGENAUTO" "ON")
(COMMAND "ERASE" DBF "")
(SETVAR "CLAYER" CL)
(PRINC)
);END SM

marijan.marsic
2010-08-23, 11:37 AM
(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)


Moderator Note:

Please use [ CODE ] tags to display code. (http://forums.augi.com/misc.php?do=bbcode#code)

sbradley268277
2011-06-17, 09:06 PM
Hey gang,

I know this is an old thread, but I just tried this in AutoCAD Plant 3D 2011 and I am getting this:

Command: sm
*STATION MARK*
Pick first station location:
Select station line:
Starting station mark # <0>:
Descend <Ascend>:
Station segment length <50>:
Symbol scale <nil>:
Unknown command "SM". Press F1 for help.
Unknown command "SM". Press F1 for help.
0.000000
*Invalid*
; error: Function cancelled

Any ideas?

This seems to be the only solution to my problem other than using Civil 3D.

Thanks,
Stephan

aaronic_abacus
2011-06-17, 09:37 PM
I think if you run SDS.LSP first it will work.
Also make sure the blocks are in the search path.

aaronic_abacus
2011-06-17, 11:10 PM
also look at:

http://forums.augi.com/showthread.php?t=53627&highlight=station

jim.buhrdorf214720
2012-05-09, 09:09 PM
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?????

fixo
2012-05-10, 08:18 AM
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



;; 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'~

jim.buhrdorf214720
2012-05-10, 11:04 PM
Thanks, Fixo!

jim.buhrdorf214720
2012-05-10, 11:18 PM
You wouldn't happen to have the .lsp file? "STAN" at command line will not work - "STANDARDS" pops up as default. Also, do you have to have special tic and/or stationing text blocks either inserted into the drawing or in the same folder as the drawing? Thank you!

fixo
2012-05-11, 04:28 AM
Jim,
I need more detail. An image or a copy of the drawing would be make a sense.

~'J'~

raphaeldomingo469869
2012-07-14, 07:28 AM
Mr. Fixo Thanks for this codes... can you modify this to show 0+000 instead of 0+00..thanks a lot!!!

BlackBox
2012-07-14, 03:49 PM
Oleg, my friend -

I just noticed the number of vlax-Curve-* calls in your code above; you may find this thread (http://www.theswamp.org/index.php?topic=42246.0) to be of particular interest. :beer:

CadDog
2012-08-23, 09:25 PM
Here's a stationing autolisp routine I created before learning SoftDESK(land desktop).
(see attachments)



(DEFUN C:SM (/ LP BP LOP LUP SLPS SLEN SLPP SLNPP SLEPP SLLA SLL CL SL NO SMN XS EV1 EVS SV EV2 PEP1 PEP2 FIP MARK NMSS DBO ISMN DBF LOOP IP RA PM SMSP SMSS SMS JC1 JC2 JS FLTR)
(SETQ DBO 0)
(SETQ ISMN 0)
(SETQ NO NIL)
(PROMPT "*STATION MARK*")
(SETQ LP 1)
(WHILE LP
(SETQ BP (GETPOINT "\nPick first station location: "))
(SETQ BP (OSNAP BP "NEA"))
(IF (/= BP NIL)
(SETQ LP NIL)
(PROMPT " POINT NOT ON STATION LINE ")
)
);END WHILE LP
(SETQ LUP 1)
(WHILE LUP
(SETQ LOP 1)
(WHILE LOP
(SETQ SLPS (ENTSEL "\nSelect station line: "))
(IF (/= SLPS NIL)
(SETQ LOP NIL)
(PROMPT " NO OBJECT SELECTED ")
)
);END WHILE LOP
(SETQ SLEN (CAR SLPS))
(IF (= (CDR (ASSOC 0 (ENTGET SLEN))) "LWPOLYLINE")
(SETQ LUP NIL)
(PROMPT " OBJECT SELECTED NOT A POLYLINE ")
)
);END WHILE LUP
(SETQ SLPP (CADR SLPS))
(SETQ SLNPP (OSNAP SLPP "NEA"))
(COMMAND "BREAK" SLNPP "F" BP BP)
(SETQ SLEN (SSNAME (SSGET SLNPP) 0))
(SETQ SLLA (ASSOC 8 (ENTGET SLEN)))
(SETQ SLL (CDR SLLA))
(SETQ CL (GETVAR "CLAYER"))
(SETVAR "CLAYER" SLL)
(SETQ SMN (GETREAL "\nStarting station mark # <0>: "))
(IF (= SMN NIL)
(SETQ SMN 0)
)
(INITGET "A D")
(SETQ NO (GETKWORD "\nDescend <Ascend>: "))
(IF (= NO NIL)
(SETQ NO "A")
)
(SETQ SL (GETREAL "\nStation segment length <50>: "))
(IF (= SL NIL)
(SETQ SL 50.0)
)
(PROMPT "\nSymbol scale <")
(PRINC DWGSCALE)
(PROMPT ">: ")
(SETQ XS (GETREAL))
(IF (= XS NIL)
(SETQ XS DWGSCALE)
)

(SETQ SLENL (ENTGET SLEN))
(SETQ EV1 (CDR (ASSOC 10 SLENL)))
(SETQ EVS EV1)
(SETQ SV 1)
(WHILE SV
(SETQ SLENL (CDR SLENL))
(SETQ EVT (ASSOC 10 SLENL))
(IF (/= EVT NIL)
(SETQ EV2 (CDR EVT))
(SETQ SV NIL)
)
);END WHILE SV
(SETQ PEP1 EV1)
(SETQ PEP2 EV2)
(IF (> (DISTANCE SLNPP PEP2) (DISTANCE SLNPP PEP1))
(SETQ FIP PEP1)
(SETQ FIP PEP2)
)

(COMMAND "INSERT" "MARK" FIP XS "" SLNPP)
(SETQ MARK (ENTLAST))
(COMMAND "REGENAUTO" "OFF")
(COMMAND "MEASURE" SLNPP "B" "MARK" "Y" (* SL 12))
(SETQ NMSS (SSLENGTH (SSGET "P")))
(IF (> (DISTANCE FIP (CDR (ASSOC 10 (ENTGET (ENTNEXT MARK)))))
(+ (* SL 12) 1)
)
(PROGN (SETQ DBO 1) (SETQ ISMN 1))
(SETQ DBO 0)
)
(COMMAND "POINT" "@")
(SETQ DBF (ENTLAST))
(COMMAND "SETVAR" "ATTREQ" "0")
(SETQ LOOP 1)
(WHILE LOOP
(SETQ ELIST (ENTGET MARK))
(SETQ IP (CDR (ASSOC 10 ELIST)))
(SETQ RA (/ (* 180 (CDR (ASSOC 50 ELIST))) PI))
(SETQ RA (- RA (* (FIX (/ RA 360)) 360)))
(IF (AND (> RA 90) (< RA 270))
(SETQ RA (+ RA 180))
)
(SETQ PM MARK)
(SETQ MARK (ENTNEXT MARK))
(COMMAND "ERASE" PM "")
(COMMAND "INSERT" "STMK" IP XS "" RA)
(SETQ SMSP (FIX (/ SMN 100)))
(SETQ SMSS (- SMN (* SMSP 100)))
(IF (< SMSP 0)
(SETQ SMSP (* -1 SMSP))
)
(IF (< SMSS 0)
(SETQ SMSS (* -1 SMSS))
)
(IF (= SMSS 0)
(SETQ SMSS "00")
(SETQ SMSS (RTOS SMSS 2 0))
)
(SETQ SMSP (RTOS SMSP 2 0))
(SETQ SMS (STRCAT SMSP "+" SMSS))
(COMMAND "ATTEDIT" "N" "N" "STMK" "STMK" "STMK" "STMK" SMS)
(IF (AND (= ISMN 1) (= NO "A"))
(PROGN (SETQ SMN (+ (+ (* NMSS SL) SMN) SL)) (SETQ ISMN 0))
)
(IF (AND (= ISMN 1) (= NO "D"))
(PROGN (SETQ SMN (- SMN (+ (* NMSS SL) SL))) (SETQ ISMN 0))
)
(IF (AND (= DBO 1) (= NO "A"))
(SETQ SMN (- SMN SL))
)
(IF (AND (= DBO 0) (= NO "A"))
(SETQ SMN (+ SMN SL))
)
(IF (AND (= DBO 1) (= NO "D"))
(SETQ SMN (+ SMN SL))
)
(IF (AND (= DBO 0) (= NO "D"))
(SETQ SMN (- SMN SL))
)
(IF (= (CDR (ASSOC 0 (ENTGET MARK))) "POINT")
(SETQ LOOP NIL)
)
);END WHILE
(SETQ JC1 (MAPCAR '+ BP '(0.01 0.01 0.0)))
(SETQ JC2 (MAPCAR '- BP '(0.01 0.01 0.0)))

(SETQ
FLTR (LIST '(-4 . "<AND") SLLA '(0 . "POLYLINE") '(-4 . "AND>"))
)
(SETQ JS (SSGET "C" JC1 JC2 FLTR))
(COMMAND "PEDIT" SLEN "J" JS "" "X")
(COMMAND "SETVAR" "ATTREQ" "1")
(COMMAND "REGENAUTO" "ON")
(COMMAND "ERASE" DBF "")
(SETVAR "CLAYER" CL)
(PRINC)
);END SM[ Moderator Action = ON ] What are [ CODE ] tags... (http://forums.augi.com/misc.php?do=bbcode#code) [ Moderator Action = OFF ]

Thanks aaronic_abacus for your code.

With a little adjustment I was able to get it to work for civil plans...
Civil 3D is cool but sometime I like to work fast without messing around with all the tabs they have.

Here are a few things I changed...
(SETQ DWGSCALE (GETVAR "DIMSCALE"))

I don't need to work your sas by adding this...

(COMMAND "MEASURE" SLNPP "B" "MARK" "Y" (* SL 1)) ;WAS SET TO 12

(IF (> (DISTANCE FIP (CDR (ASSOC 10 (ENTGET (ENTNEXT MARK)))))
(+ (* SL 1) 1);change from 12 to 1
This now works on civil full size plans.

That is it... I'm going to try to place tangent lines with stationing next.

Thanks again for this base code it is great of you to share... :)