Label Rectangle

January 29, 2018

Hi,

I´m working with the Code "Labelrec".

It works perfect, but is it possible to write always the lenght from the rectangle as first in the text line? e.g. when the length is smaller then the width.

(defun c:LabelRec (/ ActDoc CurSpace Ht ss cnt Ent EntData VerPoints tmpEnt Wid Len Pt Str tmpText tmpDist1 tmpDist2)
; Label rectangles with length and width in middle of them.

(vl-load-com)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(if (= (getvar "cvport") 1)
(setq CurSpace (vla-get-PaperSpace ActDoc))
(setq CurSpace (vla-get-ModelSpace ActDoc))
)
(if (and (setq Ht (getreal "\n Enter height of text: ")) (setq ss (ssget '((0 . "*POLYLINE")))))
(progn
 (setq cnt 0)
 (while (setq Ent (ssname ss cnt))
  (setq EntData (entget Ent))
  (if (= (cdr (assoc 0 EntData)) "LWPOLYLINE")
   (setq VerPoints (vlax-get (vlax-ename->vla-object Ent) 'Coordinates))
   (progn
    (setq VerPoints nil)
    (setq tmpEnt (entnext Ent))
    (while (not (equal (cdr (assoc 0 (entget tmpEnt))) "SEQEND"))
     (setq tmpPt (cdr (assoc 10 (entget tmpEnt))))
     (setq VerPoints (append VerPoints (list (car tmpPt))))
     (setq VerPoints (append VerPoints (list (cadr tmpPt))))
     (setq tmpEnt (entnext tmpEnt))
    )
   )
  )
  (if (= (length VerPoints) 
   (progn
    (setq tmpDist1 (distance (list (nth 0 VerPOints) (nth 1 VerPoints)) (list (nth 2 VerPoints) (nth 3 VerPoints))))
    (setq tmpDist2 (distance (list (nth 2 VerPOints) (nth 3 VerPoints)) (list (nth 4 VerPoints) (nth 5 VerPoints))))
    (if (< tmpDist1 tmpDist2)
     (setq Len tmpDist2 Wid tmpDist1)
     (setq Len tmpDist1 Wid tmpDist2)
    )
    (setq Pt (list (/ (+ (nth 0 VerPoints) (nth 4 VerPoints)) 2.0) (/ (+ (nth 1 VerPoints) (nth 5 VerPoints)) 2.0) 0.0))
    (setq Str (strcat (rtos Len 2 2) "x" (rtos Wid 2 2)))
    (setq tmpText (vla-AddText CurSpace Str (vlax-3d-point Pt) Ht))
    (vla-put-Alignment tmpText 4)
    (vla-put-TextAlignmentPoint tmpText (vlax-3d-point Pt))
   )
  )
  (setq cnt (1+ cnt))
 )
)
)
(princ)
)

Thank for your help

January 29, 2018

Try the following code:

(defun c:labelrec ( / ent enx hgt idx len lst sel vte vtx wid zco )
   (initget 6)
   (setq hgt (cond ((getdist (strcat "\nSpecify text height <" (rtos (getvar 'textsize)) ">: "))) ((getvar 'textsize))))

   (if
       (setq sel
           (ssget
              '(
                   (0 . "*POLYLINE")
                   (-4 . "&=") (70 . 1)
                   (-4 . "<OR")
                       (-4 . "<AND")
                           (0 . "LWPOLYLINE")
                           (90 . 4)
                           (-4 . "<NOT")
                               (-4 . "<>") (42 . 0.0)
                           (-4 . "NOT>")
                       (-4 . "AND>")
                       (-4 . "<AND")
                           (0 . "POLYLINE")
                           (-4 . "<NOT")
                               (-4 . "&") (70 . 94)
                           (-4 . "NOT>")
                       (-4 . "AND>")
                   (-4 . "OR>")
               )
           )
       )
       (repeat (setq idx (sslength sel))
           (setq idx (1- idx)
                 ent (ssname sel idx)
                 enx (entget ent)
                 lst nil
           )
           (if (= "LWPOLYLINE" (cdr (assoc 0 enx)))
               (setq zco (cdr (assoc 38 enx))
                     lst (mapcar '(lambda ( x ) (list (cadr x) (caddr x) zco)) (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
               )
               (progn
                   (setq vte (entnext ent)
                         vtx (entget  vte)
                   )
                   (while  (= "VERTEX" (cdr (assoc  0 vtx)))
                       (setq lst (cons (cdr (assoc 10 vtx)) lst)
                             vte (entnext vte)
                             vtx (entget  vte)
                       )
                   )
               )
           )
           (if (= 4 (length lst))
               (progn
                   (setq len (distance (car  lst) (cadr  lst))
                         wid (distance (cadr lst) (caddr lst))
                   )
                   (if (< len wid) (setq lst (cdr lst)))
                   (entmake
                       (list
                          '(000 . "TEXT")
                          '(072 . 4)
                          '(073 . 0)
                           (cons  040 hgt)
                           (cons  001 (strcat (rtos len 2 2) "x" (rtos wid 2 2)))
                           (cons  010 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car lst) (caddr lst)))
                           (cons  011 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car lst) (caddr lst)))
                           (cons  050 (LM:readable (angle (car lst) (cadr lst))))
                           (assoc 210 enx)
                       )
                   )
               )
           )
       )
   )
   (princ)
)

;; Readable  -  Lee Mac
;; Returns an angle corrected for text readability.

(defun LM:readable ( a )
   (   (lambda ( a )
           (if (< a 0.0)
               (LM:readable a)
               (if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
                   (LM:readable (+ a pi))
                   a
               )
           )
       )
       (rem (+ a pi pi) (+ pi pi))
   )
)

(princ)

Edited July 27, 2020 by Lee Mac

January 30, 2018

Hi Lee,

Thank you for the answer.

Can you change the lisp file that

the text from the rectangle look like the example image file.

Thank you for your help.

Example.dwg

January 30, 2018

No problem - I've updated the above code.

January 30, 2018

Hi, Lee

Thank you very much.

You help me a lot.

( I also use programms from your website:))

January 30, 2018

Excellent - you're welcome!

July 27, 2020

Hi, i have been trying to use LabelRec with AutoCAD 2019, and i have many issues. I will list them.

If i try to use the Code above (original script) i get UNKNOWN COMMAND even though i load the lsp
If i mess around with the (parentheses) i get it to run, but it goes into an infinite loop on only the first rectangle selected
If i cancel out on the routine, i still get the label for that rectangle. Actually i get around 80.000 duplicates for every second it runs.

Can you help me out on this? Im not really a programmer and im having a real hard time ( been trial and error'n all morning) I will attach two lisp files.

LabelRecOriginal is the code exactly as seen pasted onto notepad++ and saved as .lsp

l1 is my modified version that runs on an infinite loop.Run it but once it starts working cancel(ESC) immediately. If you don't its gonna crash eventually.

My guess is that something is way of with the () on the original but no matter what i try it doesn't work properly..

Thanks for any input btw!

PS LeeMac You have been my hero for years on no end. Thanx for everything!

LabelRecOriginal.lsp l1.lsp

Edited July 27, 2020 by Hector

July 27, 2020

Thank you for your kind words - I've updated my earlier post to remove the BBCode formatting tags.

July 28, 2020

Bless you m8!!

May 3, 2024

[XDrX-PlugIn(161)] Label Rectangle (theswamp.org)

https://www.theswamp.org/index.php?topic=59529.0

There are currently 161 plugins written, see: https://www.theswamp.org/index.php?board=78.0

1. Eliminate unnecessary vertices
2. Modify the starting point to the lower left point (X is the smallest and Y is the smallest), and the clockwise direction is counterclockwise.
3. Align the text on the long side, and mark the text on the horizontal side first.

(defun c:xdtb_reclabel (/ cen centroid label minpt pts ss txt x xdir)
  (xd::doc:getdouble (xdrx-string-multilanguage "\n文字高度" "\nText Height")
		     "#xd-var-global-text-height" 3.5
  )
  (xd::doc:getint (xdrx-string-multilanguage "\n小数位数" "\ndecimal places")
		  "#xd-var-global-num-bits" 1
  )
  (if (setq ss (xdrx-ssget (xdrx-string-multilanguage "\n选择矩形<退出>:" "\nSelect Rectangle<Exit>:")
			   '((0 . "*polyline"))
	       )
      )
    (progn
      (xdrx-begin)
      (mapcar
	'(lambda (x)
	   (if (xd::polyline:isrectang x)
	     (progn
	       (xdrx-polyline-compress x)
	       (setq pts (xdrx-getpropertyvalue x "vertices")
		     minpt (xd::pnts:minx->miny pts 1e-5)
		     minpt (car minpt)
	       )
	       (xdrx-curve-setclosed x)
	       (xdrx-polyline-resetstartpoint x minpt)
	       (setq pts (xdrx-getpropertyvalue x "vertices")
		     xdir (xdrx-vector-normalize (mapcar
						   '-
						   (nth 1 pts)
						   (nth 0 pts)
						 )
			  )
	       )
	       (if (< (distance (nth 1 pts) (nth 0 pts)) (distance
								   (nth 1
									pts
								   )
								   (nth 2
									pts
								   )
							 )
		   )
		 (setq xdir (xdrx-vector-normalize (mapcar
						     '-
						     (nth 2 pts)
						     (nth 1 pts)
						   )
			    )
		 )
	       )
	       (setq label (strcat (rtos (distance (car pts) (cadr pts)) 2
					 #xd-var-global-num-bits
				   ) "x" (rtos (distance (cadr pts)
							 (caddr pts)
					       ) 2 #xd-var-global-num-bits
					 )
			   )
	       )
	       (setq centroid (xdrx-getpropertyvalue x "centroid"))
	       (setq txt (xdrx-text-make centroid label
					 #xd-var-global-text-height
			 )
		     cen (xdrx-getpropertyvalue txt "centroid")
	       )
	       (xdrx-entity-align txt cen '(1 0 0) centroid xdir)
	       (xd::text:adjust txt)
	       (xdrx-setpropertyvalue txt "horizontalmode" 1 "verticalmode"
				      2 "alignmentpoint" centroid "color" 1
	       )
	     )
	   )
	 )
	(xdrx-ss->ents ss)
      )
      (xdrx-end)
    )
  )
  (princ)
)

=====================

The above code uses XDrx API, download link:

https://github.com/xdcad/XDrx-API-zip

https://sourceforge.net/projects/xdrx-api-zip/

Dual version link:

https://github.com/xdcad

Sign In

Label Rectangle

Recommended Posts

Juergen

Lee Mac

Juergen

Lee Mac

Juergen

Lee Mac

Hector

Lee Mac

Hector

XDSoft

Join the conversation

Tutorials

Forums

Activity