marko_ribar Posted March 8, 2013 Posted March 8, 2013 I've changed Station symbol to : Ch 2+200 m for ex. - it means 2200 m, but you can change "+" if you want to anything else, and if you don't want it just change it to "" - empty string... Also I've changed rotation of attribute to be opposite than initial - changed (/ pi 2) to (* pi 1.5) - in your red line : (vla-put-rotation at_obj (/ pi 9))... Also changed X,Y and Z scale factors of Station block during insertion to be : 5 5 5... Also changed text height of attribute from 1.5 to 1.0... So here is mine version - little bit changed formatting of code, but it looks almost the same : (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) Hope this helps... M.R. Quote
izzner Posted April 1, 2013 Posted April 1, 2013 hi there.. i am a newbie when it comes to LISP.. can anyone tell me how do i start this LISP routine...?? I have already loaded this LSP in Autocad using "Appload" but now how do i start/invoke this script?? any help will be highly appreciated.. regards, oops sorry my bad *** Type D10 to execute *** Quote
woodman78 Posted April 3, 2013 Posted April 3, 2013 marko, I just saw your response to this now. Sorry about that. It works great now after I made the alterations you suggested for the chainage to display the way I want it. A couple of things though: Can it be setup not to rotate the chainage as it does currently on an arc? We choose one way and leave it run over the full length like that. Another thing is the placing of a rounded chainage at the end of the line even though its not correct. We also put a short green tick mark at 10m intervals. This doesn't have any text and is simply a block containing a line. But if I use the normal measure command it will place them to coincide with the 100m marks as well. Is there a way around this? Thanks marko. Quote
woodman78 Posted April 5, 2013 Posted April 5, 2013 Fixo, Are you able to help with this? Thanks Quote
BruceAdams Posted January 12, 2015 Posted January 12, 2015 I've done a little work on this routine, for running SEQ: stationing for underground fiber optic lines. Pretty easy to change "SEQ:" to "Sta:" in the routine. This equal distance is 25' on this one. See below. (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 25) (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" 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 0.90) (strcat "SEQ 0+" (if (equal num 0 1e-15) "00" (rtos num 2 0)) "") (strcat "SEQ: " (itoa (fix (/ num 100.))) "+" (if (equal (- num (* (fix (/ num 100.)) 100)) 0 1e-15) "00" (rtos (- num (* (fix (/ num 100.)) 100)) 2 0)) "" ) ) ) (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) Quote
aji2015 Posted November 22, 2017 Posted November 22, 2017 Hi all, what would need to change in the code to have a pure run of numbers (without the decimal places) ? eg. when it reaches 1000 the chainage currently goes to 1+0.00 ...... I am looking to display a simple 1000 and then 1010, 1020, 1030 and so on. Thanks for any help. Quote
ronjonp Posted November 22, 2017 Posted November 22, 2017 Hi all, what would need to change in the code to have a pure run of numbers (without the decimal places) ? eg. when it reaches 1000 the chainage currently goes to 1+0.00 ...... I am looking to display a simple 1000 and then 1010, 1020, 1030 and so on. Thanks for any help. Try this: (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 (and pl (or (setq step (getdist "\Enter step distance [<10>]: ")) (setq step 10))) (progn (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" 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 (strcat "SEQ " (rtos num 2 0))) (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") Quote
ronjonp Posted November 22, 2017 Posted November 22, 2017 You beauty Excellent. Thanks v much. You're welcome. Quote
Recommended Posts
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.