Topic: Stationing Lisp

[Scott]

Hello all,

I'm looking for an easy way to put stationing on centerlines of berm and for pipelines.  I know I can use the Measure command to mark the stations, but I have to manually put in the station id ie 0+00, 1+00 etc.  Does anyone know of a way to automate the station id input.  I'm using Map 5.  Any help is greatly appreciated.

Scott

[wizman]

Hello all,

I'm looking for an easy way to put stationing on centerlines of berm and for pipelines.  I know I can use the Measure command to mark the stations, but I have to manually put in the station id ie 0+00, 1+00 etc.  Does anyone know of a way to automate the station id input.  I'm using Map 5.  Any help is greatly appreciated.

Scott

http://forums.augi.com/showthread.php?t=69720&highlight=FIXO

[Scott]

Wizman

Thanks for the link, but it won't work.  Probably user error.  It says there is no text/mtext with similar properties selected.  Anyway, I've been playing with the measure command.  Does anyone know if there is a way to scale a block before it is inserted with the measure command?  I also need to be able to automate the station id.  I'm to lazy to explode all the blocks and change each one individually.

Thanks again

Scott

[Fatty]

Here is my 10-minutes solution
Not sure about that what you exactly need
Let me know if you want to change something here

Code: [Select]

(defun C:STN  (/ hgt init pt)
  (princ "\n Stationing pipelines ")

  (setq hgt (getreal "\n Enter text height: "))
  (setq init (getint "\n  Enter initial number <0>: "))
  (if (not init)
    (setq init 0)
    )
  (command "._undo" "e")
  (command "._undo" "g")
  (while (setq pt (getpoint "\n  Pick point to label (hit Enter to stop):"))
    (entmake
      (list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 1 (strcat (itoa init) "+00"))
(cons 10 pt)
(cons 40 hgt)
(cons 50 0.0)
(cons 51 0.0)
(cons 11 pt)
(cons 71 0)
(cons 72 1)
(cons 73 1)
)
      )
    (setq init (1+ init))
    )
  (command ".undo" "e")
  (princ)
  )
(princ "\ Start command with STN to run")
(princ)

~'J'~

[Scott]

Fatty

I can make this work if it is possible to have the text aline parellel with a line running perpendicular to my pipeline.  Is this possible?

[Scott]

This is what I am looking for.
Again Thanks for the help!!

[kpblc]

try (i didn't test it)

Code: [Select]

(defun c:stn (/ hgt init pt)
  (vl-load-com)
  (princ "\n Stationing pipelines ")

  (if (and (member (type (setq hgt
                                (vl-catch-all-apply
                                  '(lambda (/ text_height)
                                     (setq text_height
                                            (cond
                                              ((= 0.
                                                  (cdr (assoc
                                                         40
                                                         (entget
                                                           (tblobjname
                                                             "style"
                                                             (getvar "textstyle")
                                                             ) ;_ end of tblobjname
                                                           ) ;_ end of entget
                                                         ) ;_ end of assoc
                                                       ) ;_ end of cdr
                                                  ) ;_ end of =
                                               3.5
                                               )
                                              (t
                                               (cdr
                                                 (assoc
                                                   40
                                                   (entget
                                                     (tblobjname "style" (getvar "textstyle"))
                                                     ) ;_ end of entget
                                                   ) ;_ end of assoc
                                                 ) ;_ end of cdr
                                               )
                                              ) ;_ end of cond
                                           ) ;_ end of setq
                                     (cond
                                       ((getreal (strcat "\n Enter text height <"
                                                         (rtos text_height 2)
                                                         ">: "
                                                         ) ;_ end of strcat
                                                 ) ;_ end of getreal
                                        )
                                       (t text_height)
                                       ) ;_ end of cond
                                     ) ;_ end of lambda
                                  ) ;_ end of vl-catch-all-apply
                               ) ;_ end of setq
                         ) ;_ end of type
                   (list 'int 'real)
                   ) ;_ end of member
           (= (type (setq init (vl-catch-all-apply
                                 '(lambda ()
                                    (cond
                                      ((getint "\n  Enter initial number <0>: "))
                                      (t 0)
                                      ) ;_ end of cond
                                    ) ;_ end of lambda
                                 ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'int
              ) ;_ end of =
           ) ;_ end of and
    (progn
      (vla-endundomark
        (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
        ) ;_ end of vla-endundomark
      (vla-startundomark adoc)
      (while
        (= (type (setq
                   ent (vl-catch-all-apply
                         '(lambda ()
                            (entsel "\nSelect an entity <Cancel> : ")
                            ) ;_ end of lambda
                         ) ;_ end of vl-catch-all-apply
                   ) ;_ end of setq
                 ) ;_ end of type
           'list
           ) ;_ end of =
         (setq pline (vlax-ename->vla-object (car ent))
               pt    (vlax-curve-getclosestpointto pline (cadr ent))
               ) ;_ end of setq
         (entmakex (list
                     (cons 0 "TEXT")
                     (cons 100 "AcDbEntity")
                     (cons 100 "AcDbText")
                     (cons 1 (strcat (itoa init) "+00"))
                     (cons 10 pt)
                     (cons 40 2.5)
                     (cons 50
                           (- (angle '(0. 0. 0.)
                                     (vlax-curve-getfirstderiv
                                       pline
                                       (vlax-curve-getparamatpoint pline pt)
                                       ) ;_ end of vlax-curve-getSecondDeriv
                                     ) ;_ end of angle
                              (/ pi 2.)
                              ) ;_ end of -
                           ) ;_ end of cons
                     ) ;_ end of list
                   ) ;_ end of entmakex
         (setq init (1+ init))
         ) ;_ end of while
      (vla-endundomark adoc)
      ) ;_ end of progn
    ) ;_ end of if
  (princ)
  ) ;_ end of defun
(princ "\ Start command with STN to run")
(princ)

[Scott]

I get the following when I run the lisp.

 stn
 Stationing pipelines
 Enter text height <3.5000>:
  Enter initial number <0>:
Select an entity <Cancel> : ; error: bad argument value: AcDbCurve 1074538688
Command:

[Scott]

kpblc

Okay I figured out why is wasn't working.  When I use measrue to insert my cross line, it comes in as a block.  The block has to be exploded before your routine will work.  No the only problem with the routine is the station ID comes in rotated 90 degrees from what it should be.  Idealy, I would have a routine that would invoke the measure command or some other method of inserting the station marks and automatically insert the station id as well.  I'm guessing this would take some time to write the code, and I don't want to impose on anyone.  So for now, if I can get the measure command and your routine to work I will use them.  Anyway to incorporate this routine in with yours?

http://www.theswamp.org/index.php?topic=15117.0



Thanks

Scott

[CAB]

Scott,
If you would post a sample DWG with the stationing blocks along a centerline and one for pipelines
it would help.

[CAB]

As for the angle, change this

Code: [Select]

         (entmakex (list
                     (cons 0 "TEXT")
                     (cons 100 "AcDbEntity")
                     (cons 100 "AcDbText")
                     (cons 1 (strcat (itoa init) "+00"))
                     (cons 10 pt)
                     (cons 40 2.5)
                     (cons 50
                           (- (angle '(0. 0. 0.)
                                     (vlax-curve-getfirstderiv
                                       pline
                                       (vlax-curve-getparamatpoint pline pt)
                                     ) ;_ end of vlax-curve-getSecondDeriv
                              ) ;_ end of angle
                              (/ pi 2.)
                           ) ;_ end of -
                     ) ;_ end of cons
                   ) ;_ end of list
         ) ;_ end of entmakex

to this

Code: [Select]

         (setq curDer (vlax-curve-getfirstderiv cCurve
                        (vlax-curve-getparamatpoint cCurve Pt)))
         ;; Get angle 90 deg to curve
         (if (= (cadr curDer) 0.0)
           (setq curAng (/ pi 2))
           (setq curAng (- pi (atan (/ (car curDer) (cadr curDer)))))
         )
         (entmakex (list
                     (cons 0 "TEXT")
                     (cons 100 "AcDbEntity")
                     (cons 100 "AcDbText")
                     (cons 1 (strcat (itoa init) "+00"))
                     (cons 10 pt)
                     (cons 40 2.5)
                     (cons 50 curAng)
                   ) ;_ end of list
         ) ;_ end of entmakex

[kpblc]

Another version (CAB, your code more professional):

Code: [Select]

(defun c:stn2 (/            adoc         blk_def      blk_name     ent
               ent_blk      txt_height   ini_num      len          att
               sys_lst      lastent      lst_ent      loc:set-angle
               loc:conv-to-vla           loc:set-attr loc:get-attr res_height
               )

  (defun loc:conv-to-vla (ent)
    (cond
      ((= (type ent) 'vla-object) ent)
      (t (vlax-ename->vla-object ent))
      ) ;_ end of cond
    ) ;_ end of defun

  (defun loc:set-angle (ent / ang)
    (setq
      ang (+ (* pi 0.5) (vla-get-rotation (setq ent (loc:conv-to-vla ent))))
      ) ;_ end of setq
    (vla-put-rotation
      (loc:conv-to-vla ent)
      (cond
        ((<= ang pi) (+ ang pi))
        ((<= ang (* pi 1.5)) (- ang pi))
        (t ang)
        ) ;_ end of cond
      ) ;_ end of vla-put-Rotation
    ) ;_ end of defun

  (defun loc:get-attr (ent)
    (car (vlax-safearray->list
           (vlax-variant-value (vla-getattributes (loc:conv-to-vla ent)))
           ) ;_ end of vlax-safearray->list
         ) ;_ end of car
    ) ;_ end of defun

  (defun loc:set-attr (ent ini)
    (vla-put-textstring
      (car (vlax-safearray->list
             (vlax-variant-value (vla-getattributes (loc:conv-to-vla ent)))
             ) ;_ end of vlax-safearray->list
           ) ;_ end of car
      (strcat (itoa ini) "+00")
      ) ;_ end of vla-put-textstring
    ) ;_ end of defun

  (defun *error* (msg)
    (if sys_lst
      (mapcar '(lambda (x) (setvar (car x) (cdr x))) sys_lst)
      ) ;_ end of if
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (setq sys_lst (mapcar '(lambda (x) (cons x (getvar x)))
                        '("osmode" "cmdecho" "nomutt")
                        ) ;_ end of mapcar
        ) ;_ end of setq
  (if
    (and
      (member
        (type
          (setq txt_height
                 (vl-catch-all-apply
                   '(lambda (/ h)
                      (if (= 0.
                             (setq h (vla-get-height
                                       (vla-get-activetextstyle adoc)
                                       ) ;_ end of vla-get-Height
                                   ) ;_ end of setq
                             ) ;_ end of =
                        (setq h 2.5)
                        ) ;_ end of if
                      (cond
                        ((getdist (strcat "\nEnter text height <"
                                          (vl-princ-to-string h)
                                          "> : "
                                          ) ;_ end of strcat
                                  ) ;_ end of getdist
                         )
                        (t h)
                        ) ;_ end of cond
                      ) ;_ end of lambda
                   ) ;_ end of vl-catch-all-apply
                ) ;_ end of setq
          ) ;_ end of type
        (list 'real 'int)
        ) ;_ end of member
      (= (type (setq ini_num (vl-catch-all-apply
                               '(lambda ()
                                  (cond
                                    ((getint "\nInitial number <0> : "))
                                    (t 0)
                                    ) ;_ end of cond
                                  ) ;_ end of lambda
                               ) ;_ end of vl-catch-all-apply
                     ) ;_ end of setq
               ) ;_ end of type
         'int
         ) ;_ end of =
      (member (type (setq len (vl-catch-all-apply
                                '(lambda ()
                                   (cond
                                     ((getdist "\nLength of segment <1> : "))
                                     (t 1.)
                                     ) ;_ end of cond
                                   ) ;_ end of lambda
                                ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              (list 'int 'real)
              ) ;_ end of member
      (= (type (setq
                 ent (vl-catch-all-apply
                       '(lambda ()
                          (car (entsel "\nSelect a [poly]line <Cancel> : "))
                          ) ;_ end of lambda
                       ) ;_ end of vl-catch-all-apply
                 ) ;_ end of setq
               ) ;_ end of type
         'ename
         ) ;_ end of =
      ) ;_ end of and
     (progn
       (setq lastent (entlast)
             ini_num (1- ini_num)
             ) ;_ end of setq
       (if (not (tblobjname "block" (setq blk_name "scott_mark")))
         (progn
           (setq blk_def (vla-add (vla-get-blocks adoc)
                                  (vlax-3d-point '(0. 0. 0.))
                                  blk_name
                                  ) ;_ end of vla-add
                 ) ;_ end of setq
           (vla-addline
             blk_def
             (vlax-3d-point '(-2.5 0. 0.))
             (vlax-3d-point '(2.5 0. 0.))
             ) ;_ end of vla-addline
           (setq att (vla-addattribute
                       blk_def
                       txt_height
                       acattributemodenormal
                       "mark"
                       (vlax-3d-point '(3. 0. 0.))
                       "mark"
                       ""
                       ) ;_ end of vla-AddAttribute
                 ) ;_ end of setq
           (vla-put-alignment att acalignmentmiddleleft)
           (vla-put-insertionpoint att (vlax-3d-point '(3.0 0. 0.)))
           (vla-put-textalignmentpoint att (vlax-3d-point '(3.0 0. 0.)))
           (vlax-for subent blk_def
             (vla-put-layer subent "0")
             (vla-put-color subent 0)
             (vla-put-lineweight subent aclnwtbyblock)
             (vla-put-linetype subent "byblock")
             ) ;_ end of vlax-for
           ) ;_ end of progn
         ) ;_ end of if
       (mapcar '(lambda (x) (setvar (car x) (cdr x)))
               '(("osmode" . 0) ("cmdecho" . 0) ("nomutt" . 1))
               ) ;_ end of mapcar
       (vl-cmdf "_.measure" ent "_b" blk_name "_y" len)
       (while (setq lastent (entnext lastent))
         (if (not (vlax-erased-p (vlax-ename->vla-object lastent)))
           (setq lst_ent (cons (loc:conv-to-vla lastent) lst_ent))
           ) ;_ end of if
         ) ;_ end of while
       (vl-cmdf "_.attsync" "_n" blk_name)
       (foreach item lst_ent
         (if (/= (setq res_height (vla-get-height (loc:get-attr item)))
                 txt_height
                 ) ;_ end of /=
           (vla-scaleentity
             item
             (vla-get-insertionpoint item)
             (/ txt_height res_height)
             ) ;_ end of vla-scaleentity
           ) ;_ end of if
         (vla-update item)
         (loc:set-angle item)
         (loc:set-attr item (setq ini_num (1+ ini_num)))
         ) ;_ end of foreach
       ) ;_ end of progn
     ) ;_ end of if
  (if sys_lst
    (mapcar '(lambda (x) (setvar (car x) (cdr x))) sys_lst)
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun---
I modified code to set new text height

[Scott]

Cab

Attached is the drawing of what I'm looking for and my current procedure for obtaining the results.

kpblc

I tried your routine, and I must be doing something wrong.  It inserts the station mark fine, but I can't figure out how to the the station ID to come in.

Thanks for the help

[Scott]

kpblc

I'm getting an "error collecting attribute data" message when I run your lisp.

Any Ideas?

Scott

[Fatty]

Try this instead

Code: [Select]

(defun C:DP  (/ ang ccw coors d step dif dis en
      hgt init ip len n obj sign st txp)
;; ========= convert radians to degrees=====================;;
(defun rtd (a)
  (* 180.0 (/ a pi))
)
;;
(defun dif-angle (ang1 ang2 / step)
  (set 'ang1
       (if (> ang2 (+ pi ang1))
(+ (* pi 2) ang1)
ang1
       )
  )
  (set 'ang2
       (if (> ang1 (+ pi ang2))
(+ (* pi 2) ang2)
ang2
       )
  )
  (setq step (- ang2 ang1))
)
;;
(defun ccw-test (pt_list / angle_list)
  (setq angle_list
(mapcar (function (lambda (x y)
     (angle x y)
   )
)
pt_list
(cdr pt_list)
)
  )
  (if (> (apply '+
(mapcar (function (lambda (x y) (dif-angle x y)))
angle_list
(cdr angle_list)
)
)
0
      )
    t
    nil
  )
)
;;;written by Luis Esquivel

(defun get-coors (obj / cnt lst)
(setq cnt (fix (vlax-curve-getendparam obj)))
(while (> cnt 0)
  (setq lst (cons (vlax-curve-getpointatparam obj cnt) lst)
cnt (1- cnt)))
       lst
  ) 
;;========= get perpendicular angle to curve ===============;;
;; written by CAB
(defun perp_angle (obj pt / fder)
 
(setq fder (vlax-curve-getfirstderiv obj
                        (vlax-curve-getparamatpoint obj
  (vlax-curve-getclosestpointto obj pt))))

(if (equal (cadr fder) 0.0 0.001)
           (setq ang (/ pi 2))
           (setq ang (- pi (atan (/ (car fder) (cadr fder)))))
         )
  ang
  )
 
;;=================== entmake text=========================;;
 
  (defun emake-text (pt ang hgt i /)
    (entmake
      (list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 1 (strcat (itoa init) "+00"))
(cons 10 pt)
(cons 40 hgt)
(cons 50 ang)
(cons 51 0.0)
(cons 11 pt)
)
      )
    )
 
;;=====================  < main part >  ==================;;
 
  (princ "\n Stationing pipelines ")
  (command "._undo" "e")
  (command "._undo" "g")
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (if
  (setq obj (vlax-ename->vla-object (car (setq en (entsel)))))
  (progn
    (setq hgt (getreal "\n Enter text height <15>: "))
    (if (not hgt)
    (setq hgt 15)
    )
  (setq init (getint "\n  Enter initial number <0>: "))
  (if (not init)
    (setq init 0)
    ) 
  (setq st (cadr en))
 
  (setq len
         (vlax-curve-getdistatparam obj
   (vlax-curve-getendparam obj))
) 
 

  (setq coors (get-coors obj)
ccw (ccw-test coors)
)

  (if (not step)
      (setq step 100)
    )
  (setq d (getdist (strcat "\nStep of stations in cm <" (rtos step) ">: ")))
  (if (not d) (setq d step) (setq step d)
    )
  (if (< (vlax-curve-getdistatpoint obj
   (vlax-curve-getclosestpointto obj st))
       (- (vlax-curve-getdistatpoint obj
   (vlax-curve-getendpoint obj))
         (vlax-curve-getdistatpoint obj
   (vlax-curve-getclosestpointto obj st)))
   )
    (progn
    (setq sign 1
  dis 0)
    )
    (progn
    (setq sign -1
  dis len)
    )
    )
   
  (setq n (fix (/ len d))
dif (- len (* n d))
)
 
  (repeat (1+ n)
  (setq ip (vlax-curve-getpointatdist obj dis)
      ang (perp_angle obj ip)
      )

 (command "._-insert" "STA" ip  1 1 (rtd (if ccw (+ ang (/ pi 2))(- ang (/ pi 2)))))

 (setq txp (polar ip (if ccw ang (+ pi ang)) (* hgt 3)));<-- text gap from pipeline
 (emake-text txp (if ccw ang (+ pi ang)) hgt init)

(setq dis (+ dis (* sign d)))
(setq init (1+ init))
)
    )
  )
  (setvar "cmdecho" 1)
  (setvar "osmode" 175)
  (command ".undo" "e")
  (princ)
  )
(vl-load-com)
(princ "\nType DP to stationing ")
(princ)

~'J'~

[Scott]

Fatty

You are the man!!!

This works perfect.

Thanks for the help.

Scott

[Fatty]

Always happy to help, but I have not have
a time to varnish it
Change to your suit by yourself

Cheers

~'J'~

[Jeff_M]

As usual I'm a bit late to the party. Anyway, here's my offering which allows the beginning station to be any number, which happens often for me when tying to existing designs. I also use the existing STA block, if it exists in the drawing but does not have an attribute for the Station then I add it to the block def.

Code: [Select]

(defun c:station (/ ANG ATT ATTS BLK BLKREF DERV DOC ENT LINE PAD PARM SPACE STA TMPSTA)
  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (if (not (tblsearch "block" "sta"))
    (progn
      (setq blk (vlax-invoke (vla-get-blocks doc) 'add '(0.0 0.0 0.0) "sta"))
      (setq line (vlax-invoke blk 'addline '(0.0 31.25 0.0) '(0.0 -31.25 0.0)))
      (vla-put-layer line "0")
      (vla-put-color line acbylayer)
      (setq att (vlax-invoke blk 'addattribute
  15.0
  acAttributeModeNormal
  "Station number?: "
  '(0.0 35.0 0.0)
  "STATION"
  "0+00"))
      (vla-put-layer att "0")
      (vla-put-color att acbylayer)
      )
    (if (and (setq blk (vla-item (vla-get-blocks doc) "sta"))
     (= (vla-get-count blk) 1)
     )
      (progn
(setq att (vlax-invoke blk 'addattribute
  15.0
  acAttributeModeNormal
  "Station number?: "
  '(0.0 35.0 0.0)
  "STATION"
  "0+00"))
(vla-put-layer att "0")
(vla-put-color att acbylayer)
(vla-put-rotation att (* pi 1.5))
(vla-put-alignment att acAlignmentMiddleRight)
(vlax-put att 'TextAlignmentPoint '(0.0 35.0 0.0))
)
      )
    )
  (while (and (setq ent (car (entsel)))
      (setq sta (getreal "Starting station: "))
      )
    (setq tmpsta (fix (/ sta 100))
  pad (- sta (* tmpsta 100.0))
  space (vla-get-modelspace doc)
  )
    (if (/= pad 0.0)
      (setq tmpsta (1+ tmpsta))
      )
    (while (<= (* tmpsta 100) (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)))
      (setq parm (vlax-curve-getparamatdist ent (- (* tmpsta 100.0) pad)))
      (setq derv (vlax-curve-getfirstderiv ent parm))
      (if (= (car derv) 0.0)
(setq ang (/ pi 2))
(setq ang (atan (/ (cadr derv) (car derv))))
)
      (setq blkref (vlax-invoke space 'insertblock (vlax-curve-getpointatparam ent parm) "sta" 1.0 1.0 1.0 ang))
      (setq atts (vlax-invoke blkref 'getattributes))
      (setq att (car atts))
      (vla-put-textstring att (strcat (itoa tmpsta) "+00"))
      (setq tmpsta (1+ tmpsta))
      )
    )
  (princ)
  )


[Fatty]

Huh,
You beat me again
Brilliance one, Jeff

Regards
 :kewl:
~'J'~