Contour Labeling Lisp

[johnshar123xx]

On another forum a member by the name of "fixo" was nice enough to write this lisp for me but I just need a little help with it, if anyone can.

Basically this lisp takes the "z" elevation of a contour and places the value in a rectangle above the contour line. The only slight problem I had with it is, I would like to be able to increase the size of the rectangle around the text. If I use a different font, it gets close to the rectangle, which you can notice even more so when plotted.

I was wondering if someone can point out what numbers within the lisp I would have to change in order to increase the offset of this rectangle around the text. I am assuming it is towards the bottom where it says "text box".

The lisp is a nice one for labeling contours without having to break the contour lines, hopefully others can use it. Again if "fixo" reads this, I thank you again for your help.

(defun alg-ang	(obj pnt)
  (angle '(0. 0. 0.)
	 (vlax-curve-getfirstderiv
	   obj
	   (vlax-curve-getparamatpoint
	     obj
	     pnt
	     )
	   )
	 )
  )


(defun C:LAB(/ ang angp box dv en ent p1 p2 p3 p4 pt txten txthgt txtpt wid zstr zvalue)

  (setvar "osmode" 512)
  (setq txthgt 3.2);<--text height
    (if
    (setq ent (entsel "\nSelect contour line >>"))
     (progn
       (setq en (car ent))
       
  (while (setq pt (getpoint "\nPick a point on the contour (or press Enter to Exit) >> "))
    
    (setq pt	 (vlax-curve-getclosestpointto en pt)
	  zvalue (caddr pt)
	  zstr	 (rtos zvalue 2 0)
	  dv	 (vlax-curve-getfirstderiv
		   en
		   (vlax-curve-getparamatpoint en pt))
	  ang	 (alg-ang en pt)
	  ang
		 (cond ((< (/ pi 2) ang (* pi 1.5)) (+ pi ang))
		       (T ang)
		       
	  )
	   angp (+ (/ pi 2) ang)
	   txtpt (polar pt angp 0.2)
	  )

       (entmake
       (list
       '(0 . "TEXT")
       '(100 . "AcDbEntity")
       (cons 67
	  (if (= 0 (getvar "tilemode"))
	    1
	    0))
       (cons 410 (getvar "ctab"))
       '(8 . "C-TOPO-TEXT");<-- layer for texts
       '(100 . "AcDbText")
       (cons 10 txtpt)
       (cons 11  txtpt)
       (cons 40 txthgt)
       (cons 1 zstr)
       (cons 50 ang)
       '(41 . 1.0)
       '(51 . 0.0)
       '(7 . "Regular");<-- text style
       '(71 . 0)
       '(72 . 1)
       '(73 . 0)
       )
       )
    (setq txten (entlast)
	  elist (entget txten)
	  box (textbox (entget txten))
	  wid (abs (apply '- (mapcar 'car box)))
	  p1 (polar pt (+ ang pi) (+ (/ wid 2) 0.2))
	  p2 (polar pt ang (+ (/ wid 2) 0.2))
	  p4 (polar p1 angp (+ txthgt 0.4))
	  p3 (polar p2 angp (+ txthgt 0.4))
	  )

(entmake
    (append
    (list
    '(0 . "LWPOLYLINE")
    '(100 . "AcDbEntity")
    (cons 8  "C-TOPO-TEXT")
    '(100 . "AcDbPolyline")
    (cons 90 4) 
    (cons 70 1)
    (cons 43 0.0) 
    )
    (mapcar '(lambda (x) (cons 10 x)) (list p1 p2 p3 p4))	    
    )
    )
    
    )
       )
    )
       (princ)
    )
(vl-load-com)
(princ "\n\t\t***Start command with LAB ...   ***")
(prin1)
    (vl-load-com)

Sorry for the *edit*, but code reads much better when the "Code" button is used.
For further details please refer to "Reading and Posting Messages" on the FAQs Page.

[fixo]

On another forum a member by the name of "fixo" was nice enough to write this lisp for me but I just need a little help with it, if anyone can.

Basically this lisp takes the "z" elevation of a contour and places the value in a rectangle above the contour line. The only slight problem I had with it is, I would like to be able to increase the size of the rectangle around the text. If I use a different font, it gets close to the rectangle, which you can notice even more so when plotted.

I was wondering if someone can point out what numbers within the lisp I would have to change in order to increase the offset of this rectangle around the text. I am assuming it is towards the bottom where it says "text box".

The lisp is a nice one for labeling contours without having to break the contour lines, hopefully others can use it. Again if "fixo" reads this, I thank you again for your help.

Did you want increase offset rectangle gap from text?
Let me minute

~'J'~

[fixo]

Try edited lisp

(defun alg-ang (obj pnt)
  (angle '(0. 0. 0.)
  (vlax-curve-getfirstderiv
    obj
    (vlax-curve-getparamatpoint
      obj
      pnt
      )
    )
  )
  )
 
(defun C:LAB(/ ang angp box dv en ent p1 p2 p3 p4 pt txten txthgt txtpt wid zstr zvalue)
  (setvar "osmode" 512)
  (setq txthgt 3.2;<-- text height
 gap (/ txthgt 4));<-- change gap here
    (if
    (setq ent (entsel "\nSelect contour line >>"))
     (progn
       (setq en (car ent))
 
  (while (setq pt (getpoint "\nPick a point on the contour (or press Enter to Exit) >> "))
 
    (setq pt  (vlax-curve-getclosestpointto en pt)
   zvalue (caddr pt)
   zstr  (rtos zvalue 2 0)
   dv  (vlax-curve-getfirstderiv
     en
     (vlax-curve-getparamatpoint en pt))
   ang  (alg-ang en pt)
   ang
   (cond ((< (/ pi 2) ang (* pi 1.5)) (+ pi ang))
         (T ang)
 
   )
    angp (+ (/ pi 2) ang)
    txtpt (polar pt angp gap)
   )
       (entmake
       (list
       '(0 . "TEXT")
       '(100 . "AcDbEntity")
       (cons 67
   (if (= 0 (getvar "tilemode"))
     1
     0))
       (cons 410 (getvar "ctab"))
       '(8 . "C-TOPO-TEXT");<-- layer for texts
       '(100 . "AcDbText")
       (cons 10 txtpt)
       (cons 11  txtpt)
       (cons 40 txthgt)
       (cons 1 zstr)
       (cons 50 ang)
       '(41 . 1.0)
       '(51 . 0.0)
       '(7 . "Regular");<-- text style
       '(71 . 0)
       '(72 . 1)
       '(73 . 0)
       )
       )
    (setq txten (entlast)
   elist (entget txten)
   box (textbox (entget txten))
   wid (abs (apply '- (mapcar 'car box)))
   p1 (polar pt (+ ang pi) (+ (/ wid 2) gap))
   p2 (polar pt ang (+ (/ wid 2) gap))
   p4 (polar p1 angp (+ txthgt (* gap 2)))
   p3 (polar p2 angp (+ txthgt (* gap 2)))
   )
(entmake
    (append
    (list
    '(0 . "LWPOLYLINE")
    '(100 . "AcDbEntity")
    (cons 8  "C-TOPO-TEXT")
    '(100 . "AcDbPolyline")
    (cons 90 4) 
    (cons 70 1)
    (cons 43 0.0) 
    )
    (mapcar '(lambda (x) (cons 10 x)) (list p1 p2 p3 p4))     
    )
    )
 
    )
       )
    )
       (princ)
    )
(vl-load-com)
(princ "\n\t\t***Start command with LAB ...   ***")
(prin1)
(vl-load-com)

~'J'~

[steveo]

Try edited lisp

(defun alg-ang (obj pnt)
  (angle '(0. 0. 0.)
  (vlax-curve-getfirstderiv
    obj
    (vlax-curve-getparamatpoint
      obj
      pnt
      )
    )
  )
  )
 
(defun C:LAB(/ ang angp box dv en ent p1 p2 p3 p4 pt txten txthgt txtpt wid zstr zvalue)
  (setvar "osmode" 512)
  (setq txthgt 3.2;<-- text height
 gap (/ txthgt 4));<-- change gap here
    (if
    (setq ent (entsel "\nSelect contour line >>"))
     (progn
       (setq en (car ent))
 
  (while (setq pt (getpoint "\nPick a point on the contour (or press Enter to Exit) >> "))
 
    (setq pt  (vlax-curve-getclosestpointto en pt)
   zvalue (caddr pt)
   zstr  (rtos zvalue 2 0)
   dv  (vlax-curve-getfirstderiv
     en
     (vlax-curve-getparamatpoint en pt))
   ang  (alg-ang en pt)
   ang
   (cond ((< (/ pi 2) ang (* pi 1.5)) (+ pi ang))
         (T ang)
 
   )
    angp (+ (/ pi 2) ang)
    txtpt (polar pt angp gap)
   )
       (entmake
       (list
       '(0 . "TEXT")
       '(100 . "AcDbEntity")
       (cons 67
   (if (= 0 (getvar "tilemode"))
     1
     0))
       (cons 410 (getvar "ctab"))
       '(8 . "C-TOPO-TEXT");<-- layer for texts
       '(100 . "AcDbText")
       (cons 10 txtpt)
       (cons 11  txtpt)
       (cons 40 txthgt)
       (cons 1 zstr)
       (cons 50 ang)
       '(41 . 1.0)
       '(51 . 0.0)
       '(7 . "Regular");<-- text style
       '(71 . 0)
       '(72 . 1)
       '(73 . 0)
       )
       )
    (setq txten (entlast)
   elist (entget txten)
   box (textbox (entget txten))
   wid (abs (apply '- (mapcar 'car box)))
   p1 (polar pt (+ ang pi) (+ (/ wid 2) gap))
   p2 (polar pt ang (+ (/ wid 2) gap))
   p4 (polar p1 angp (+ txthgt (* gap 2)))
   p3 (polar p2 angp (+ txthgt (* gap 2)))
   )
(entmake
    (append
    (list
    '(0 . "LWPOLYLINE")
    '(100 . "AcDbEntity")
    (cons 8  "C-TOPO-TEXT")
    '(100 . "AcDbPolyline")
    (cons 90 4) 
    (cons 70 1)
    (cons 43 0.0) 
    )
    (mapcar '(lambda (x) (cons 10 x)) (list p1 p2 p3 p4))     
    )
    )
 
    )
       )
    )
       (princ)
    )
(vl-load-com)
(princ "\n\t\t***Start command with LAB ...   ***")
(prin1)
(vl-load-com)

~'J'~

Many times for accurate analysis we use contour intervals of 0.5 feet. Where in the program can we set the decimal accuracy to at least one decimal place ? Do it with cons = ??

[fixo]

Many times for accurate analysis we use contour intervals of 0.5 feet. Where in the program can we set the decimal accuracy to at least one decimal place ? Do it with cons = ??

Take a look at this line:

 
zstr  (rtos zvalue 2 0)

Sorry I'm metric perhaps would be

zstr  (rtos zvalue 4 1)

Test it by yourself

~'J'~

[steveo]

Take a look at this line:

 
zstr  (rtos zvalue 2 0)

Sorry I'm metric perhaps would be

zstr  (rtos zvalue 4 1)

Test it by yourself

~'J'~

Perfect help, thank you !!!!!!!

[johnshar123xx]

Fixo you have done it again, that works perfect, it is exactly what I was looking for. Thank you so much for all your help with this lisp, it is greatly appreciated. It is also nice to see that other members are using the lisp as well.

[fixo]

Fixo you have done it again, that works perfect, it is exactly what I was looking for. Thank you so much for all your help with this lisp, it is greatly appreciated. It is also nice to see that other members are using the lisp as well.

You're welcome

Glad if that helps

Cheers

~'J'~

[tom.haws]

Here's one I just wrote/started that elevates and labels contours at an interval. Saves your settings and tries to require minimal interaction. It's a bit too long to post here, so I'm pasting the header only, which gives you the location where you can get it.

http://autocad.wikia.com/wiki/Contou...P_application)

;;; Contour Elevations at Intervals with Labels
;;; Copyleft 2017 Thomas Gail Haws licensed under the terms of the GNU GPL
;;; http://www.hawsedc.com tom.haws@gmail.com
;;; Version: 1.0.0
;;; Official Repository: http://autocad.wikia.com/wiki/Contour_Elevations_at_Intervals_with_Labels_(AutoLISP_application
;;; Haws is a registered reserved symbol with Autodesk that will never conflict with other apps.
;;;
;;; Features:
;;; -Uses an exploded block for labeling so you can customize label as needed.
;;; -Saves to (setcfg) to remember settings between sessions.  Saves to a single global variable during a session.
;;; -Lets you ignore Interval, Label Precision, Label Spacing, Temporary Color, LabelBlockName, and Elevation or change them on the fly.
;;; -For programmers, demonstrates small functions with self-documenting names and variable names.  Also demonstrates settings management.

[tom.haws]

fixo,

We ought to combine your C:LAB with the C:CEI that I spiffed up and put at AutoCAD Wiki. It seems like everybody and their brother wants a routine to elevate and/or label contours. My CEI elevates and labels them. It should be easy enough to create an option to just label a selection set.

Tom

Take a look at this line:

 
zstr  (rtos zvalue 2 0)

Sorry I'm metric perhaps would be

zstr  (rtos zvalue 4 1)

Test it by yourself

~'J'~