Page 1 of 4 1234 LastLast
Results 1 to 10 of 33

Thread: Stationing Autolisp routine

  1. #1
    I could stop if I wanted to
    Join Date
    2006-04
    Posts
    466
    Login to Give a bone
    0

    Default Stationing Autolisp routine

    Here's a stationing autolisp routine I created before learning SoftDESK(land desktop).
    (see attachments)

    Code:
    (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... [ Moderator Action = OFF ]
    Attached Files Attached Files
    Last edited by aaronic_abacus; 2011-11-13 at 09:55 PM. Reason: [CODE] tags added.

  2. #2
    Member
    Join Date
    2003-01
    Posts
    4
    Login to Give a bone
    0

    Question Re: Stationing Autolisp routine

    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
    Last edited by robertlynch; 2010-03-03 at 05:48 PM. Reason: didnt make sense

  3. #3
    The Silent Type RobertB's Avatar
    Join Date
    2000-01
    Location
    Seattle WA USA
    Posts
    5,859
    Login to Give a bone
    0

    Default Re: Stationing Autolisp routine

    Quote Originally Posted by robertlynch View Post
    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?
    R. Robert Bell
    Design Technology Manager
    Stantec
    Opinions expressed are mine alone and do not reflect the views of Stantec.

  4. #4
    Member
    Join Date
    2003-01
    Posts
    4
    Login to Give a bone
    0

    Default Re: Stationing Autolisp routine

    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)
    Last edited by robertlynch; 2010-03-03 at 06:32 PM. Reason: additional info

  5. #5
    I could stop if I wanted to
    Join Date
    2006-04
    Posts
    466
    Login to Give a bone
    0

    Default Re: Stationing Autolisp routine

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

  6. #6
    Woo! Hoo! my 1st post
    Join Date
    2010-08
    Posts
    1
    Login to Give a bone
    0

    Default Re: Stationing Autolisp routine

    Anyway to make this work for a 3D Poly?

  7. #7
    I could stop if I wanted to
    Join Date
    2006-04
    Posts
    466
    Login to Give a bone
    0

    Default Re: Stationing Autolisp routine

    ; This version will work with 3DPOLYs

    Code:
    (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
    Attached Files Attached Files
    Last edited by aaronic_abacus; 2011-11-14 at 10:52 PM.

  8. #8
    Active Member
    Join Date
    2007-09
    Location
    Croatia
    Posts
    55
    Login to Give a bone
    0

    Default Re: Stationing Autolisp routine

    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)
    Attached Files Attached Files
    Last edited by Opie; 2010-08-23 at 02:09 PM. Reason: [code] tags added

  9. #9
    Woo! Hoo! my 1st post
    Join Date
    2011-06
    Posts
    1
    Login to Give a bone
    0

    Unhappy Re: Stationing Autolisp routine

    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

  10. #10
    I could stop if I wanted to
    Join Date
    2006-04
    Posts
    466
    Login to Give a bone
    0

    Default Re: Stationing Autolisp routine

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

Page 1 of 4 1234 LastLast

Similar Threads

  1. Replies: 1
    Last Post: 2014-04-15, 06:15 PM
  2. Routine to Play Winamp via AutoLISP
    By Adesu in forum AutoLISP
    Replies: 0
    Last Post: 2007-02-08, 01:36 AM
  3. Select Similar Autolisp routine
    By VBOYAJI in forum AutoLISP
    Replies: 9
    Last Post: 2006-06-28, 05:31 PM
  4. Please help with Autolisp routine about Printing
    By Matt Mercer in forum AutoLISP
    Replies: 9
    Last Post: 2006-03-09, 03:27 PM
  5. HELP: need to run 2 Autolisp routine at a time
    By bradipos in forum AutoLISP
    Replies: 0
    Last Post: 2004-09-28, 01:06 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •