Lisp to Label Contours

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.

November 27, 2013

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