Jump to content
Juergen

Label Rectangle

Recommended Posts

Juergen

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

Share this post


Link to post
Share on other sites
Lee Mac

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 by Lee Mac

Share this post


Link to post
Share on other sites
Juergen

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.jpg

Example.dwg

Share this post


Link to post
Share on other sites
Lee Mac

No problem - I've updated the above code.

Share this post


Link to post
Share on other sites
Juergen

Hi, Lee

 

Thank you very much.

You help me a lot.

 

( I also use programms from your website:))

Share this post


Link to post
Share on other sites
Lee Mac

Excellent - you're welcome!

Share this post


Link to post
Share on other sites
Hector
Posted (edited)

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 by Hector

Share this post


Link to post
Share on other sites
Lee Mac

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

Share this post


Link to post
Share on other sites
Hector

Bless you m8!!

Share this post


Link to post
Share on other sites

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.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


×
×
  • Create New...