Jump to content

polyline kilometer along


sadefa

Recommended Posts

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 by sadefa
Link to comment
Share on other sites

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.pline km.jpg

Edited by sadefa
Link to comment
Share on other sites

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)

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...