cgv Posted November 26, 2013 Share Posted November 26, 2013 Hi, Does anyone know of any good lisp routines that will allow you to select a polyline which has a Z vales and have it place a text label of the elevation over the line with a background mask? It would really help out. Thanks. Quote Link to comment Share on other sites More sharing options...
ymg3 Posted November 27, 2013 Share Posted November 27, 2013 (edited) Here is a dynamic one modified from an Alan J Thompson routine. Your contour must be on layer "Major Contour" and "Minor Contour" for it to work. ;; c:dlbl Dynamic Contour Labeling by ymg ; ;; ; ;; Extension to LCE program by Alan J. Thompson ; ;; http://www.theswamp.org/index.php?topic=39644.msg449399#msg449399 ; ;; Code for grread loop from Freebird at TheSwamp ; ;; ; ;; Tab, Toggles from Major Contour Only to All Contours. ; ;; +, Increase Size of Text Labels. ; ;; -, Decrease Size of Text Labels. ; ;; Left-Click, Enter a Point for the Fence. ; ;; Right-Click, Undo to Previous Point of Fence. ; ;; u, Undo to Previous Point of Fence. ; ;; Space, Terminates the Command. ; ;; Enter, Terminates the Command. ; ;; ; (defun c:dlbl (/ *AcadDoc* *error* *util* angl b code ent errl i id loop lst lwp maj mtxtlst obj obj1 obj2 p point prev space ss text) (vl-load-com) ;;; Error Handler by ElpanovEvgenyi ; (defun *error* (msg) (mapcar 'eval errl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (and *AcadDoc* (vla-endundomark *AcadDoc*)) (princ) ) (setq errl '("CLAYER" "OSMODE" "CMDECHO" "DIMZIN") errl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) errl) ) (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))) (setvar 'CMDECHO 0) (setvar 'DIMZIN 0) (setvar 'OSMODE 0) (defun Intersections (obj1 obj2 mode) ;; Return list of intersection(s) between two objects ;; obj1 - first VLA-Object ;; obj2 - second VLA-Object ;; mode - intersection mode (acExtendNone acExtendThisEntity acExtendOtherEntity acExtendBoth) ;; Alan J. Thompson, 12.13.10 ((lambda (foo) (foo (vlax-invoke obj1 'IntersectWith obj2 mode))) (lambda (l) (if (cddr l) (cons (list (car l) (cadr l) (caddr l)) (foo (cdddr l))) ) ) ) ) (defun AngleAtPoint (e p) ;; Return angle along curve, at specified point (on curve) ;; e - valid curve (ENAME or VLA-OBJECT) ;; p - point on curve ;; Alan J. Thompson, 11.04.10 (angle '(0. 0. 0.) (vlax-curve-getFirstDeriv e (vlax-curve-getParamAtPoint e p))) ) (defun MakeReadable (ang) ;; Make angle readable ;; Alan J. Thompson, 12.14.10 (if (and (> ang (/ pi 2.)) (<= ang (* pi 1.5))) (+ ang pi) ang ) ) (defun _lwp (l) (vlax-ename->vla-object (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length l)) '(70 . 0) ) (mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) l) ) ) ) ) ;; mk_layer by CAB at TheSwamp.org ; ;; Optionnal Arguments by ymg. ; ;; Routine to ENTAKE a TEXT entity. ; ;; ; ;; If the layer already exist, it will be: thawed ; ;; set on ; ;; unlocked ; ;; set as the current layer. ; ;; ; (defun mk_layer (argl / lay Color ltype) (setq lay (car argl) color (cadr argl) ltype (caddr argl) ) (if (tblsearch "LAYER" lay) (progn (if color (progn (setq ent (tblobjname "LAYER" lay) ent (entget ent) ent (subst (cons 62 color) (assoc 62 ent) ent) ) (entmod ent) ) ) (if ltype (progn (setq ent (tblobjname "LAYER" lay) ent (entget ent) ent (subst (cons 6 ltype) (assoc 6 ent) ent) ) (entmod ent) ) ) (command "._Layer" "_Thaw" lay "_On" lay "_UnLock" lay "_Set" lay "") ) (progn (entmake (list (cons 0 "LAYER") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord") (cons 2 lay) (cons 70 0) (cons 62 (if (or (null color)(= Color "")) 7 Color)) (cons 6 (if (or (null ltype)(= ltype "")) "Continuous" ltype)) (cons 290 1) (cons 370 -3) ) ) ) ) ) (defun getmtext (plst / ) (setq mtxtlst nil) (if maj (setq ss (ssget "_F" plst (list '(0 . "LWPOLYLINE")(cons 8 "Contour Major")))) (setq ss (ssget "_F" plst (list '(0 . "LWPOLYLINE")(cons 8 "Contour Major,Contour Minor")))) ) (if ss (progn (setq lwp (_lwp plst) space (if (eq (getvar 'CVPORT) 1) (vla-get-paperspace *AcadDoc*) (vla-get-modelspace *AcadDoc*) ) point (vlax-3d-point '(0. 0. 0.)) angl (if (zerop (getvar 'WORLDUCS)) (angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 t) t)) 0. ) *util* (vla-get-utility *AcadDoc*) ) (mk_layer (list "Contour Label")) (repeat (setq i (sslength ss)) (setq obj (vlax-ename->vla-object (ssname ss (setq i (1- i)))) id (if (vlax-method-applicable-p *util* 'GetObjectIdString) (vla-GetObjectIdString *util* obj :vlax-false) (itoa (vla-get-ObjectId obj)) ) ) (vla-put-elevation lwp (vla-get-elevation obj)) (foreach p (Intersections lwp obj acExtendNone) (setq text (vla-addMText space point 0. (strcat "%<\\AcObjProp.16.2 Object(%<\\_ObjId " id ">%).Elevation \\f \"%lu2%pr2%zs8\">%" ) ) ) (vlax-put-property text 'BackgroundFill :vlax-true) (vla-put-attachmentpoint text acAttachmentPointMiddleCenter) (vla-put-insertionpoint text (vlax-3d-point p)) (vla-put-rotation text (MakeReadable (- (AngleAtPoint obj p) angl))) (setq mtxtlst (cons (entlast) mtxtlst)) (vlax-release-object text) ) ) (if lwp (progn (entdel (vlax-vla-object->ename lwp)) (vlax-release-object lwp) (vlax-release-object obj) ) ) ) ) mtxtlst ) (setq loop t lst nil prev nil ) (vla-startundomark *AcadDoc*) (while loop (setq code (grread t ) (cond ((= (car code) 5) (if lst (progn (redraw) (if prev (mapcar 'entdel prev)) (setq prev (getmtext (cons (cadr code) lst))) (mapcar '(lambda (a b) (grdraw a b 2 1)) lst (cons (cadr code) lst) ) ) ) ) ((= (car code) 3) (setq lst (cons (cadr code) lst))) ; Left Click, Add point to fence. ; ((= (car code) 25) (if (> (length lst) 1) (setq lst (cdr lst)))) ; Right Click, Undo. ; ((equal code '(2 13)) (redraw)(setq loop nil)) ; Enter, Exit the loop. ; ((equal code '(2 32)) (redraw)(setq loop nil)) ; Space, Exit the loop. ; ((equal code '(2 9)) (if maj (setq maj nil)(setq maj t))) ; Tab, toggles majcontour only. ; ((equal code '(2 117))(if (> (length lst) 1) (setq lst (cdr lst)))) ; u, Undo. ; ((equal code '(2 85)) (if (> (length lst) 1) (setq lst (cdr lst)))) ; U, Undo. ; ((equal code '(2 43)) (setvar 'textsize (+ (getvar 'textsize) 0.5))) ; +, Increase Text Size. ; ((equal code '(2 45)) (setvar 'textsize (- (getvar 'textsize) 0.5))) ; -, Decrease Text Size. ; ) ) (*error* nil) ) ymg Edited November 27, 2013 by ymg3 Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted November 27, 2013 Share Posted November 27, 2013 Here's another program that may help: http://www.cadtutor.net/forum/showthread.php?82346-Level-lines-calculate-height&p=562138&viewfull=1#post562138 Quote Link to comment Share on other sites More sharing options...
hawstom Posted February 20, 2017 Share Posted February 20, 2017 Here's another one that's pretty robust with options to elevate and label: http://autocad.wikia.com/wiki/Contour_Elevations_at_Intervals_with_Labels_(AutoLISP_application) Quote Link to comment Share on other sites More sharing options...
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.