Stationing Autolisp routine

[aaronic_abacus]

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]

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]

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]

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]

First use SDS to set the drawing scale,
then SM to station the the polyline.

[jeremyburt76]

Anyway to make this work for a 3D Poly?

[aaronic_abacus]

; 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]

(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]

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]

I think if you run SDS.LSP first it will work.
Also make sure the blocks are in the search path.

[aaronic_abacus]

also look at:

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

[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?????

[fixo]

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]

Thanks, Fixo!

[jim.buhrdorf214720]

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]

Jim,
I need more detail. An image or a copy of the drawing would be make a sense.

~'J'~

[raphaeldomingo469869]

Mr. Fixo Thanks for this codes... can you modify this to show 0+000 instead of 0+00..thanks a lot!!!

[BlackBox]

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]

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... :)

[022803que]

Hey, I'm a newbie to using lsp files, and need some addtional info on how to run this lsp. I would like to be able to place station markers on a polyline.

My question is "what do I type in my command line to load the lsp?"

I'm running plain jane AutoCAD 2012. I put the attachments in a folder that AutoCAD can access, I just did not see a load command. I tried (load "*station mark*") and that did not work for me. I got ;error: load failed: "*station mark*"

[022803que]

Hey, I'm new to installing lisp, and do not see a command to load the original attachments. I saved all the attachments to a file, that my AutoCAD support path can reach. I just can not figure out what command to use, to load the lsp. I know it is in the right place, I just don't know how to make the program utilize it.

What do you enter in the command line, to make the program access the lsp?

Thanks,

[aaronic_abacus]

use the appload command.
also make sure the dwg files are in the search path.

[BlackBox]

Boo Startup Suite, hooray Autoloader (2012+)! :lol:

[aaronic_abacus]

;He's my current version...




(DEFUN C:STA ()
(SETQ LUG (GETVAR "LUNITS"))
(IF (= LUG 2) (C:STAD))
(IF (OR (= LUG 3) (= LUG 4)) (C:STAE))
);END STA

(DEFUN C:STAD (/ 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 TDSD (RTOS (GETVAR "CDATE") 2 8))
(setq osm (getvar "osmode"))
(command "osnap" "off")
(SETQ CMDE (GETVAR "CMDECHO"))
(SETVAR "CMDECHO" 0)
(SETQ DBO 0)
(SETQ LU (GETVAR "LUNITS"))
(SETQ ISMN 0)
(SETQ NO NIL)
(PROMPT "\n*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
(COMMAND "ZOOM" "C" BP "1.0")
(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 ENTL (ENTGET SLEN))
(SETQ ND (CONS 1000 TDSD))
(SETQ ED '((-3 ("EDATA" (1000 . "SUB")) )) )
(SETQ EDS (CADAR ED))
(SETQ EDS2 (CAR ED))
(SETQ TDT (CAR (CDAR (CDAR ED))))
(SETQ NED (SUBST ND TDT EDS))
(SETQ NED (SUBST NED EDS EDS2))
(SETQ NED (SUBST NED EDS2 ED))
(REGAPP "EDATA")
(SETQ NED (APPEND ENTL NED))
(ENTMOD NED)
(REDRAW SLEN)
(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 (GETDIST "\nStation segment length <50>: "))
(IF (= SL NIL) (SETQ SL 50.0))
(IF (= DWGSCALE NIL) (SETQ DWGSCALE 1.0))
(PROMPT "\nSymbol scale <")
(PRINC DWGSCALE )
(PROMPT ">: ")
(SETQ XS (GETDIST))
(IF (= XS NIL) (SETQ XS DWGSCALE))
(IF (/= XS NIL) (SETQ DWGSCALE XS))
(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)
(SETQ NMSS (SSLENGTH (SSGET "P")))
(SETQ PPL (LIST))
(FOREACH N ENTL
(PROGN
(SETQ PPA (CAR N))
(SETQ PPV (CDR N))
(IF (= PPA 10) (SETQ PPL (APPEND PPL (LIST PPV))))
));END N
(SETQ PPL2 (REVERSE PPL))
(SETQ ENTPT (CAR PPL))
(SETQ ENTPT2 (CAR PPL2))
(IF (> (DISTANCE FIP ENTPT) (DISTANCE FIP ENTPT2)) (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 STMKEN (ENTLAST))
(SETQ ENTL (ENTGET STMKEN))
(SETQ ND (CONS 1000 TDSD))
(SETQ ED '((-3 ("EDATA" (1000 . "SUB")) )) )
(SETQ EDS (CADAR ED))
(SETQ EDS2 (CAR ED))
(SETQ TDT (CAR (CDAR (CDAR ED))))
(SETQ NED (SUBST ND TDT EDS))
(SETQ NED (SUBST NED EDS EDS2))
(SETQ NED (SUBST NED EDS2 ED))
(REGAPP "EDATA")
(SETQ NED (APPEND ENTL NED))
(ENTMOD NED)
(REDRAW STMKEN)
(IF (= LU 2)
(PROGN
(SETQ SMSP (FIX (/ SMN 100)))
(SETQ SMSS (- SMN (* SMSP 100)))
));END PROGN/IF LU
(IF (< SMSP 0) (SETQ SMSP (* -1 SMSP)))
(IF (< SMSS 0) (SETQ SMSS (* -1 SMSS)))
(IF (= SMSS 0) (SETQ SMSS "00") (SETQ SMSS (RTOS SMSS LU 0)))
(IF (= SMSP 0 ) (SETQ SMSP "0") (SETQ SMSP (RTOS SMSP LU 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)
(setvar "osmode" osm)
(SETVAR "CMDECHO" CMDE)
(PRINC)
);END STA


;look at the STA.LSP attachment for the second half :(

[aaronic_abacus]

; ok here's the second half(in attached above in STA.LSP)



(DEFUN C:STAE (/ 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 TDSD (RTOS (GETVAR "CDATE") 2 8))(SETQ CMDE (GETVAR "CMDECHO"))
(SETVAR "CMDECHO" 0)
(setq osm (getvar "osmode"))
(command "osnap" "off")
(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
(COMMAND "ZOOM" "C" BP "1.0")
(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 ENTL (ENTGET SLEN))
(SETQ ND (CONS 1000 TDSD))
(SETQ ED '((-3 ("EDATA" (1000 . "SUB")) )) )
(SETQ EDS (CADAR ED))
(SETQ EDS2 (CAR ED))
(SETQ TDT (CAR (CDAR (CDAR ED))))
(SETQ NED (SUBST ND TDT EDS))
(SETQ NED (SUBST NED EDS EDS2))
(SETQ NED (SUBST NED EDS2 ED))
(REGAPP "EDATA")
(SETQ NED (APPEND ENTL NED))
(ENTMOD NED)
(REDRAW SLEN)
(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))
(IF (= DWGSCALE NIL) (SETQ DWGSCALE 12.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")))
(SETQ PPL (LIST))
(FOREACH N ENTL
(PROGN
(SETQ PPA (CAR N))
(SETQ PPV (CDR N))
(IF (= PPA 10) (SETQ PPL (APPEND PPL (LIST PPV))))
));END N
(SETQ PPL2 (REVERSE PPL))
(SETQ ENTPT (CAR PPL))
(SETQ ENTPT2 (CAR PPL2))
(IF (> (DISTANCE FIP ENTPT) (DISTANCE FIP ENTPT2)) (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 STMKEN (ENTLAST))
(SETQ ENTL (ENTGET STMKEN))
(SETQ ND (CONS 1000 TDSD))
(SETQ ED '((-3 ("EDATA" (1000 . "SUB")) )) )
(SETQ EDS (CADAR ED))
(SETQ EDS2 (CAR ED))
(SETQ TDT (CAR (CDAR (CDAR ED))))
(SETQ NED (SUBST ND TDT EDS))
(SETQ NED (SUBST NED EDS EDS2))
(SETQ NED (SUBST NED EDS2 ED))
(REGAPP "EDATA")
(SETQ NED (APPEND ENTL NED))
(ENTMOD NED)
(REDRAW STMKEN)
(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)
(setvar "osmode" osm)
(SETVAR "CMDECHO" CMDE)
(PRINC)
);END SM

[tfleming787716]

I'm relatively new to LISP Routines and I have been searching for a routine that will do stationing at 100' increments. Your routine works perfectly for that. I was wondering how it could be changed to do 2 things.
1. Make the stationing text Perpendicular to the polyline instead of Parallel.
2. Add lines that will also place a station mark on a point that intersects the polyline. (ie a telephone pole) as in the snip below:
107901


Any Help at all would be greatly appreciated! Ill be trying to figure it out on my own but could really use the extra brain.

Thanks!!

[aaronic_abacus]

Attached are the full set of Station Pack files.

[tfleming787716]

Attached are the full set of Station Pack files.

Thanks, One question though, when I ran the STA file it placed the station marks at 100 ft intervals and labeled them the file labeled the 100 ft station marks and then the poles as Numbers 1 thru 6. Is there a file in this folder that will allow a station mark to be placed on each of these poles with the correct footage for each? and will any of these files turn the station mark number so that it is perpendicular to the polyline? Appreciate the help!!

[aaronic_abacus]

STA is designed to station off a centerline or survey line.
LLSO will label station and offset along the station line.


(just added the menu in the above zip file)

[gilgameshhhhy]

Hey man, I was wondering if there is a way to make your stationing be 0+000 instead of 0+00. Thanks!

[aaronic_abacus]

this version works with metric now, still working on LLSO.LSP



(DEFUN C:STA ()
(SETQ LUG (GETVAR "LUNITS"))
(IF (= LUG 2) (C:STAD))
(IF (OR (= LUG 3) (= LUG 4)) (C:STAE))
);END STA


(DEFUN C:STAD (/ 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)
(PROMPT "\n*STATION MARK*")
(COMMAND "UNDO" "M")




(IF (= MSTI NIL) (SETQ MSTI "English"))

;(SETQ MST NIL)

(PROMPT "\n Enter unit system [English / Metric] <")

(PROMPT MSTI)

(PROMPT ">: ")

(INITGET 1 "English Metric E e M m")
(SETQ MSTI2 (GETSTRING))

(IF (AND (/= MSTI2 NIL) (/= MSTI2 "")) (SETQ MSTI MSTI2))

(IF (OR (= MSTI "English") (= MSTI "E") (= MSTI "e")) (PROGN (SETQ MST 0) (SETQ MSTI "English")))

(IF (OR (= MSTI "Metric") (= MSTI "M") (= MSTI "m")) (PROGN (SETQ MST 1) (SETQ MSTI "Metric")))


(SETQ LP5B 1)
(WHILE LP5B
(INITGET 1 "Select")
(SETQ TDSD (GETSTRING T "\nEnter station line name [ Select ] <date>: "))
(IF (= TDSD "") (PROGN (SETQ TDSD (RTOS (GETVAR "CDATE") 2 8)) (SETQ LP5B NIL) ))
(IF (AND (/= TDSD "") (/= TDSD "Select") (/= TDSD "select") (/= TDSD "SELECT") (/= TDSD "S") (/= TDSD "s") (/= TDSD NIL)) (SETQ LP5B NIL))
(IF (OR (= TDSD "Select") (= TDSD "select") (= TDSD "SELECT") (= TDSD "S") (= TDSD "s"))
(PROGN
(SETQ LP5 1)
(WHILE LP5
(SETQ ENT (ENTSEL "\nSelect host entity : "))
(IF (= ENT NIL) (SETQ LP5 NIL))
(IF (/= ENT NIL)
(PROGN
(SETQ ENTL (ENTGET (CAR ENT)))
(SETQ ENTPT (CDR ENT))
(SETQ EDATAL (ENTGET (CAR ENT) '("EDATA")))
(SETQ EDBNS (ASSOC -3 EDATAL))
(SETQ EDBN (CDR (CADAR (CDR EDBNS))))
(IF (/= EDBN NIL)
(PROGN
(PRINC EDBN)
(SETQ TDSD EDBN)
(SETQ LP5 NIL)
(SETQ LP5B NIL)
);END PROGN
(PROGN
(PROMPT "\nNO EXTENDED ENTITIY DATA FOUND ")
(SETQ LP5 NIL)
);END PROGN
);END IF EDBN
));END PROGN IF ENT
);END LP5
));END PROGN/IF TDSD
);END LP5B

(setq osm (getvar "osmode"))
(command "osnap" "off")
(SETQ CMDE (GETVAR "CMDECHO"))
(SETVAR "CMDECHO" 0)
(SETQ DBO 0)
(SETQ LU (GETVAR "LUNITS"))
(SETQ ISMN 0)
(SETQ NO NIL)
(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
(COMMAND "ZOOM" "C" BP "1.0")

(SETQ BP1 (POLAR BP (* PI 0.25) 0.25))
(SETQ BP2 (POLAR BP (* PI 0.75) 0.25))
(SETQ BP3 (POLAR BP (* PI 1.25) 0.25))
(SETQ BP4 (POLAR BP (* PI 1.75) 0.25))

(GRDRAW BP1 BP3 1)
(GRDRAW BP2 BP4 1)

(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 ENTL (ENTGET SLEN))
(SETQ ND (CONS 1000 TDSD))
(SETQ ED '((-3 ("EDATA" (1000 . "SUB")) )) )
(SETQ EDS (CADAR ED))
(SETQ EDS2 (CAR ED))
(SETQ TDT (CAR (CDAR (CDAR ED))))
(SETQ NED (SUBST ND TDT EDS))
(SETQ NED (SUBST NED EDS EDS2))
(SETQ NED (SUBST NED EDS2 ED))
(REGAPP "EDATA")
(SETQ NED (APPEND ENTL NED))
(ENTMOD NED)
(REDRAW SLEN)
(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 (GETDIST "\nStation segment length <50>: "))
(IF (= SL NIL) (SETQ SL 50.0))
(IF (= DWGSCALE NIL) (SETQ DWGSCALE 10.0))
(PROMPT "\nSymbol scale <")
(PRINC DWGSCALE )
(PROMPT ">: ")
(SETQ XS (GETDIST))
(IF (= XS NIL) (SETQ XS DWGSCALE))
(IF (/= XS NIL) (SETQ DWGSCALE XS))
(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)
(SETQ NMSS (SSLENGTH (SSGET "P")))
(SETQ PPL (LIST))
(FOREACH N ENTL
(PROGN
(SETQ PPA (CAR N))
(SETQ PPV (CDR N))
(IF (= PPA 10) (SETQ PPL (APPEND PPL (LIST PPV))))
));END N
(SETQ PPL2 (REVERSE PPL))
(SETQ ENTPT (CAR PPL))
(SETQ ENTPT2 (CAR PPL2))
(IF (> (DISTANCE FIP ENTPT) (DISTANCE FIP ENTPT2)) (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 STMKEN (ENTLAST))
(SETQ ENTL (ENTGET STMKEN))
(SETQ ND (CONS 1000 TDSD))
(SETQ ED '((-3 ("EDATA" (1000 . "SUB")) )) )
(SETQ EDS (CADAR ED))
(SETQ EDS2 (CAR ED))
(SETQ TDT (CAR (CDAR (CDAR ED))))
(SETQ NED (SUBST ND TDT EDS))
(SETQ NED (SUBST NED EDS EDS2))
(SETQ NED (SUBST NED EDS2 ED))
(REGAPP "EDATA")
(SETQ NED (APPEND ENTL NED))
(ENTMOD NED)
(REDRAW STMKEN)


(IF (AND (= LU 2) (= MST 0))
(PROGN
(SETQ SMSP (FIX (/ SMN 100)))
(SETQ SMSS (- SMN (* SMSP 100)))
));END PROGN/IF LU


(IF (AND (= LU 2) (= MST 1))
(PROGN
(SETQ SMSP (FIX (/ SMN 1000)))
(SETQ SMSS (- SMN (* SMSP 1000)))
));END PROGN/IF LU


(IF (= MST 0)
(PROGN
(IF (< SMSP 0) (SETQ SMSP (* -1 SMSP)))
(IF (< SMSS 0) (SETQ SMSS (* -1 SMSS)))
(IF (= SMSS 0) (SETQ SMSS "00") (SETQ SMSS (RTOS SMSS LU 0)))
(IF (= SMSP 0 ) (SETQ SMSP "0") (SETQ SMSP (RTOS SMSP LU 0)))


(SETQ SMSSL (STRLEN SMSS))
(IF (< SMSSL 2) (SETQ SMSS (STRCAT "0" SMSS)))




(SETQ SMS (STRCAT SMSP "+" SMSS ))
));END PROGN IF MS


(IF (= MST 1)
(PROGN
(IF (< SMSP 0) (SETQ SMSP (* -1 SMSP)))
(IF (< SMSS 0) (SETQ SMSS (* -1 SMSS)))
(IF (= SMSS 0) (SETQ SMSS "000") (SETQ SMSS (RTOS SMSS LU 0)))
(IF (= SMSP 0 ) (SETQ SMSP "0") (SETQ SMSP (RTOS SMSP LU 0)))

(SETQ SMSSL (STRLEN SMSS))
(IF (< SMSSL 3) (SETQ SMSS (STRCAT "0" SMSS)))

(IF (< SMSSL 2) (SETQ SMSS (STRCAT "0" SMSS)))


(SETQ SMS (STRCAT SMSP "+" SMSS ))
));END PROGN IF MS

(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)
(setvar "osmode" osm)
(SETVAR "CMDECHO" CMDE)
(PRINC)
);END STA

[aaronic_abacus]

This version of LLSO.LSP works in metric now.




(DEFUN C:LLSO ()
(SETQ LUG (GETVAR "LUNITS"))
(IF (= LUG 2) (C:LLSOD))
(IF (OR (= LUG 3) (= LUG 4)) (C:LLSOE))
);END LLSO


(DEFUN C:LLSOD ()

(IF (= MSTI NIL) (SETQ MSTI "English"))

;(SETQ MST NIL)

(PROMPT "\n Enter unit system [English / Metric] <")

(PROMPT MSTI)

(PROMPT ">: ")

(INITGET 1 "English Metric E e M m")
(SETQ MSTI2 (GETSTRING))

(IF (AND (/= MSTI2 NIL) (/= MSTI2 "")) (SETQ MSTI MSTI2))

(IF (OR (= MSTI "English") (= MSTI "E") (= MSTI "e")) (PROGN (SETQ MST 0) (SETQ MSTI "English")))

(IF (OR (= MSTI "Metric") (= MSTI "M") (= MSTI "m")) (PROGN (SETQ MST 1) (SETQ MSTI "Metric")))

(SETQ CMDE (GETVAR "CMDECHO"))
(setq osm (getvar "osmode"))
(command "osnap" "off")
(SETVAR "CMDECHO" 0)
(SETVAR "ATTREQ" 0)
(COMMAND "REGENAUTO" "OFF")
(PROMPT "\n*LABEL LOCATION STATION OFFSET*")
(SETQ EIP (GETPOINT "\nPick point: "))
(SETQ CL NIL)
(WHILE (NOT CL)
(SETQ CL (ENTSEL "\nSelect station line: ")
);END WHILE
(SETQ ENTL (ENTGET (CAR CL)))
(SETQ ENTPT (CDR CL))
(SETQ EDATAL (ENTGET (CAR CL) '("EDATA")))
(SETQ EDBNS (ASSOC -3 EDATAL))
(SETQ EDBN (CDR (CADAR (CDR EDBNS))))
(IF (= DWGSCALE NIL) (SETQ DWGSCALE 1.0))
(PROMPT "\nSymbol scale <")
(PRINC DWGSCALE )
(PROMPT ">: ")
(SETQ XS (GETDIST))
(IF (= XS NIL) (SETQ XS DWGSCALE))
(IF (/= XS NIL) (SETQ DWGSCALE XS))
(SETQ FVP (CAR (CDR CL)))
(SETQ CTD 10000000)
(COMMAND "LINE" EIP "PER" FVP "")
(SETQ PL (ENTLAST))
(SETQ PLL (ENTGET PL))
(COMMAND "ERASE" PL "")
(SETQ LIP (CDR (ASSOC 11 PLL)))
(SETQ PTD (DISTANCE EIP LIP))
(IF (< PTD CTD) (PROGN (SETQ CTD PTD) (SETQ CCE CLE) (SETQ CIP LIP) ))
(SETQ CLE CCE)
(SETQ LIP CIP)
(SETQ PLA (ANGLE LIP EIP))
(SETQ EWP1 (POLAR LIP (+ PLA (/ PI 4)) 3000))
(SETQ EWP2 (POLAR LIP (+ PI (+ PLA (/ PI 4))) 3000))
(SETQ RMN (CONS 50
(- PLA (- (/ PI 2) (/ PI 10)))))
(SETQ RMX (CONS 50
(- PLA (+ (/ PI 2) (/ PI 10)))))
(SETQ FMN (CONS 50
(+ (- PLA (- (/ PI 2) (/ PI 10))) PI)))
(SETQ FMX (CONS 50
(+ (- PLA (+ (/ PI 2) (/ PI 10))) PI)))
(SETQ FTL '(
(2 . "STMK")
(-4 . "<AND")
(-4 . "<NOT")
(-4 . "<AND")
(-4 . ">")
(99 . "XX")
(-4 . "<")
(98 . "XX")
(-4 . "AND>")
(-4 . "NOT>")
(-4 . "<NOT")
(-4 . "<AND")
(-4 . ">")
(97 . "XX")
(-4 . "<")
(96 . "XX")
(-4 . "AND>")
(-4 . "NOT>")
(-4 . "AND>")
))
(SETQ FTL (SUBST RMN '(99 . "XX") FTL))
(SETQ FTL (SUBST RMX '(98 . "XX") FTL))
(SETQ FTL (SUBST FMN '(97 . "XX") FTL))
(SETQ FTL (SUBST FMX '(96 . "XX") FTL))
(SETQ SMS (SSGET "X" FTL))
(SETQ SMSL (SSLENGTH SMS))
(SETQ CT3 (- SMSL 1))
(SETQ CSMD 1000000)
(SETQ LP3 1)
(WHILE LP3
(SETQ SME (SSNAME SMS CT3))
(SETQ SMEL (ENTGET SME '("EDATA")))
(SETQ EDBNS (ASSOC -3 SMEL))
(SETQ SMELBN (CDR (CADAR (CDR EDBNS))))
(IF (= SMELBN EDBN) (SETQ EDBNTM 1) (SETQ EDBNTM 0))
(SETQ SMIP (CDR (ASSOC 10 SMEL)))
(SETQ SMR (CDR (ASSOC 50 SMEL)))
(SETQ SMD (DISTANCE SMIP LIP))
(IF (AND (< SMD CSMD) (= EDBNTM 1)) (PROGN (SETQ CSMD SMD) (SETQ SMIPP SMIP) (SETQ SMEP SME)))
(SETQ CT3 (- CT3 1))
(IF (< CT3 0) (SETQ LP3 NIL))
);END LP3
(SETQ SMEAL (ENTGET (ENTNEXT SMEP)))
(SETQ SMEAA (CDR (ASSOC 1 SMEAL)))
(SETQ CT3 (- SMSL 2))
(SETQ SMS2 (SSDEL SMEP SMS))
(SETQ CSMD2 100000)
(SETQ LP3 1)
(WHILE LP3
(SETQ SME2 (SSNAME SMS2 CT3))
(SETQ SME2L (ENTGET SME2 '("EDATA")))
(SETQ EDBNS (ASSOC -3 SME2L))
(SETQ SMELBN (CDR (CADAR (CDR EDBNS))))
(IF (= SMELBN EDBN) (SETQ EDBNTM 1) (SETQ EDBNTM 0))
(SETQ SMIP2 (CDR (ASSOC 10 SME2L)))
(SETQ SMR2 (CDR (ASSOC 50 SME2L)))
(SETQ SMD2 (DISTANCE SMIP2 LIP))
(IF (AND (< SMD2 CSMD2) (= EDBNTM 1)) (PROGN (SETQ CSMD2 SMD2) (SETQ SMIPP2 SMIP2) (SETQ SMEP2 SME2)))
(SETQ CT3 (- CT3 1))
(IF (< CT3 0) (SETQ LP3 NIL))
);END LP3
(SETQ SMEAL2 (ENTGET (ENTNEXT SMEP2)))
(SETQ SMEAA2 (CDR (ASSOC 1 SMEAL2)))
(SETQ CT4 1)
(SETQ LP4 1)
(WHILE LP4
(SETQ ST (SUBSTR SMEAA CT4 1))
(IF (= ST "+") (SETQ LP4 NIL) (SETQ CT4 (+ CT4 1)) )
);END WHILE LP4
(SETQ AT1 (STRCAT (SUBSTR SMEAA 1 (- CT4 1)) (SUBSTR SMEAA (+ CT4 1)) ))
(SETQ ATV (DISTOF AT1 2))
(SETQ CT5 1)
(SETQ LP5 1)
(WHILE LP5
(SETQ ST (SUBSTR SMEAA2 CT5 1))
(IF (= ST "+") (SETQ LP5 NIL) (SETQ CT5 (+ CT5 1)) )
);END WHILE LP5
(SETQ AT2 (STRCAT (SUBSTR SMEAA2 1 (- CT5 1)) (SUBSTR SMEAA2 (+ CT5 1)) ))
(SETQ ATV2 (DISTOF AT2 2))
(IF (< ATV ATV2) (SETQ NTV (+ ATV (/ CSMD 1))) (SETQ NTV (- ATV (/ CSMD 1))) )

(IF (= MST 1)
(PROGN
(SETQ NSN (FIX NTV))
(SETQ NSNP (/ NSN 1000))
(SETQ NSSP (ITOA NSNP))
(SETQ NSNS (- NSN (* NSNP 1000)))
(SETQ NSSS (ITOA NSNS))
);END PROGN

(PROGN
(SETQ NSN (FIX NTV))
(SETQ NSNP (/ NSN 100))
(SETQ NSSP (ITOA NSNP))
(SETQ NSNS (- NSN (* NSNP 100)))
(SETQ NSSS (ITOA NSNS))
));END PROGN / IF MST

(IF (< NSNS 10) (SETQ NSSS (STRCAT "0" NSSS)))

(SETQ NSSSL (STRLEN NSSS))
(IF (AND (< NSSSL 3) (= MST 1)) (SETQ NSSS (STRCAT "0" NSSS)))

(SETQ NST (STRCAT NSSP "+" NSSS))

(SETQ OFF (DISTANCE EIP LIP))
(SETQ OFT (RTOS OFF))
(SETQ SDA (/ (* (ANGLE LIP EIP) 180) PI))
(IF (AND (<= SDA 180) (>= SDA 0)) (SETQ FLGN "LL") (SETQ FLGN "LL2"))
(SETQ LIP SDA);TEST
(COMMAND "INSERT" FLGN EIP XS "" (+ SDA 180))
(SETQ FLG (ENTLAST))
(COMMAND "ATTEDIT" "N" "N" "LL*" "" "XX'" "XX'" OFT)
(COMMAND "ATTEDIT" "N" "N" "LL*" "" "X+XX" "X+XX" NST)
(SETVAR "ATTREQ" 1)
(COMMAND "REGENAUTO" "ON")
)
(setvar "osmode" osm)
(SETVAR "CMDECHO" CMDE)
(PRINC)
);END LLSO

[aaronic_abacus]

Hey man, I was wondering if there is a way to make your stationing be 0+000 instead of 0+00. Thanks!

this is metric