polyline kilometer along

[sadefa]

Hello to all,

 

I have a challenge to place text markers along a polyline. As this polyline represents the trace of an linear object (in my case cable line) I would like to have at every 250m the length from the start of the line represented as "X +YYY", where X is the kilometer and YYY are the meters. Also it would be good to have the length from the start at every vertex.

Can anyone help me with this, as I have no knowledge from lisp programing.

 

Regards and thanks in advance!

Edited June 5, 2016 by sadefa

[Tharwat]

Can you show an example with a sample drawing and what are the requested info should be given from a user ?

[sadefa]

Sorry, I do not have CAD software at the place where I am at right now, but I have an image that shows exactly what I am looking for.

Edited June 5, 2016 by sadefa

[BIGAL]

Sadefa & Tharwat so many versions are already here just search for "chainage" most can be simply changed to reflect the 3+500

 

Here is one not sure where it came from but it does mention use of +

; chainage lables of pline
;but you can change "+" if you want to anything else, and if you don't want it just change it to "" - empty string

(defun div-error (msg)
 (if
   (vl-position
     msg
     '("console break"
       "Function cancelled"
       "quit / exit abort"
      )
   )
    (princ "Error!")
    (princ msg)
 )
 (while (> (getvar "cmdactive") 0) (command))

 (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. -3. 0.)
                      (list 0. (* hgt 2.) 0.)
                    )
     )
     (vla-put-color line_obj acred)
     (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 10. 0.))
                    attag
                    "0"
                  )
     )

     (vla-put-rotation at_obj (* pi 1.5))
     (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)))

 (setq olderror *error*)
 (setq *error* div-error)

 (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 100)
     (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)
     (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"         5        5
                             5        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 900.)
                       (strcat "Ch 0+" (if (equal num 0 1e-15) "000" (rtos num 2 0)) "m")
                       (strcat
                         "Ch "
                         (itoa (fix (/ num 1000.))) "+"
                         (if (equal (- num (* (fix (/ num 1000.)) 1000)) 0 1e-15) "000" (rtos (- num (* (fix (/ num 1000.)) 1000)) 2 0))
                         "m"
                       )
                     )
                   )
                   (if (not opt)
                     (vlax-put at 'Rotation 0)
                   )
                   (vla-update at)
                 )
               )
             )
             (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
 )

 (princ)
)
(prompt "\n")
(prompt "\n    ***    Type D10 to execute    *** \n")
(princ)