draw chainage on polyline

[fixo]

And I'll keep in my lib.

@m4rdy,

Wait, please,

I'm still varnishing this code, but a bit busy with my own yet

[Lee Mac]

(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 )
...................
(setq opt (answer "Rotate text perpendicularly to pline?"))
...................

Hai Oleg,

 

This function is new to me. I like it. And I'll keep in my lib.

 

Thank you.

 

mardi

 

My version:

 

http://lee-mac.com/popup.html

[fixo]

I meant that it is necessary to varnish the basic program

But the subroutine is good enough and works with no problem

[SLW210]

>

 

when u got the mail as just write subject as "CHAINAGE LISP"

 

Regard

 

Hari

 

Please provide your help in the forum, as this provides help and information for all.

 

"Give a man a fish and he'll eat for a day, but teach a man how to fish and he will be fed for a lifetime."

[martinle]

My version:

 

http://lee-mac.com/popup.html

 

Hello Mr. Lee

 

I want to use their code

Why does not reflect the so?

Please help!

 

lg. Martin

;;-------------------------=={ Popup }==----------------------;;
;;                                                            ;;
;;  Displays a pop-up message box prompting the user.         ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  title - Text to be displayed in the pop-up title bar      ;;
;;  msg   - Text content of the pop-up message box            ;;
;;  flags - Integer indicating icon & button appearance       ;;
;;------------------------------------------------------------;;
;;  Returns:  Integer indicating the button pressed to exit   ;;
;;------------------------------------------------------------;;

(defun LM:Popup ( title msg flags / wsh res )
 (vl-catch-all-apply
   (function
     (lambda nil
       (setq wsh (vlax-create-object "WScript.Shell"))
       (setq res (vlax-invoke-method wsh 'popup msg 0 title flags))
     )
   )
 )
 (if wsh (vlax-release-object wsh))
 res
)
( LM: Popup "Titel Text"  "This is a test message".  ( +  3  32 4096 ))


;;;;;New new new

(initget "6 7 2 ")
 (cond
 ((= kw "6")(command "spiegeln" "V" "" Pause Pause "J"))
 ((= kw "7")(command "_exit"))
 ((= kw "2")(command "_exit"))
 (t 2)
 )
(princ)
)

[Lee Mac]

Hi Martin,

 

There are too many spaces in your code, and an extra "." where it shouldn't be.

 

This:

( LM: Popup "Titel Text"  "This is a test message".  ( +  3  32 4096 ))

 

Should be:

(LM:Popup "Title Text" "This is a test message." (+ 3 32 4096))

[wimal]

I meant that it is necessary to varnish the basic program

But the subroutine is good enough and works with no problem

Yes it is now working correctly.

[michaelrezk]

can someone help me fix the last chainage to show the length of the line instead of the approx. chianage

I have modified the lisp slightly to match my colours and to use pre-fix CH

 

 

 

(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 8.) 0.)))
(vla-put-color line_obj acwhite)
(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 99990.)
(strcat "CH" (rtos num 2 3))
(strcat "sta: "
(itoa (fix (/ num 1000.)));<--- changes 1200. on num (typo)
"+"
(rtos (- num (* (fix (/ num 1000.)) 1000)) 2 2)
)
))
(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
)
;;; (command "._undo" "_end")
(princ)
)
(prompt "\n")
(prompt "\n *** Type D10 to execute *** \n")
(princ)

Edited July 11, 2012 by michaelrezk

[Lee Mac]

Please use Code Tags when posting code.

[michaelrezk]

Please use Code Tags when posting code.

 

Sure I will do that in the future.

Are you able to help me with my lisp ??

[SLW210]

Sure I will do that in the future.

Are you able to help me with my lisp ??

 

How about editing your previous post to include code tags in the present.

[michaelrezk]

Guys I really need this lisp.. does any one know how to change it ??

[Philm]

I'm crazy busy and can't to rewrite it

to your exact needs but hope this

will get you started

 

(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 990.)
   (strcat "sta: 0+" (rtos num 2 2))
(strcat "sta: "
   (itoa (fix (/ num 1000.)))[color=red];<--- changes 1200. on num (typo)[/color]
   "+"
   (rtos (- num (* (fix (/ num 1000.)) 1000)) 2 2)
   )
))
           (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
 )
;;;  (command "._undo" "_end")
 (princ)
)
(prompt "\n")
(prompt "\n    ***    Type D10 to execute    *** \n")
(princ)

 

~'J'~

 

Fixo,

 

thats absolutely fantastic.

 

could anyone rejig that code to make the text size slightly bigger and is it possible to have the chainages reading as CH: 12600 rather than sta : 12+ 600 ?

 

Even if nobody knows how or has time to help me, big thanks still to fixo for the lisp and to this forum as a whole, a complete wealth of knowledge!

 

Kind Regards

 

Philip, Belfast

[woodman78]

This is a bit late but I have been messing around with this and I almost have how I want it. This is Fixo's code. I am hoping someone can help with the final few bits...

 

(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.5 ;(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-alignment at_obj acAlignmentBottomCenter)
;;;  (vla-put-textalignmentpoint
;;;    at_obj
;;;    (vlax-3d-point '(0. 1. 0.))
;;;  )

[color="red"]  (vla-put-rotation at_obj (/ pi 9))[/color]
 (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 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)
;;;      (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 990.)
   (strcat "Ch " (rtos num 2 2))
(strcat "Ch "
   (itoa (fix (/ num 1000.)));<--- changes 1200. on num (typo)
   (rtos (- num (* (fix (/ num 1000.)) 1000)) 2 2)
   )
))
           (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
 )
;;;  (command "._undo" "_end")
 (princ)
)
(prompt "\n")
(prompt "\n    ***    Type D10 to execute    *** \n")
(princ)

 

I am trying to get the text to rotate so that it looks like the image below but I have tried many alternatives but no joy... (see red text in code)

 

I am also looking to add a suffix "m" to the string.

 

Would appreciate any help on this...

Thanks

Edited February 27, 2013 by woodman78
Forgot image

[woodman78]

Hi,

I have made progress with this code but I have any issue I can't get over. I have changed the format of the text to read "Ch1000m" for example as opposed to the "Ch0+00m" that was in the original code. But now it runs up to Ch900m and then it gets messed up. Is the code below necessary with the changed format I have. I presume it was to truncate the text for the proevious format. I thought it would be straight forward to just add the number to the text string without doing anything to it...

 

(strcat "Ch " (rtos num 2 2))
(strcat "Ch "
   (itoa (fix (/ num 1000.)));<--- changes 1200. on num (typo)
   (rtos (- num (* (fix (/ num 1000.)) 1000)) 2 2)
   "m"    
   )
))

 

Could someone have a look and let me know how I can proceed?

 

Thanks.

[woodman78]

Is anyone able to help with this?

[marko_ribar]

Perhaps

 

(if ([color=red]<=[/color] num 990.)

[woodman78]

Thanks Marko but where would that go?

[woodman78]

Can anyone help with this?

[woodman78]

Can anyone point show me how to move on with this?