Lisp that writes block names to the center of the block

[bery35]

I have found a lisp on the forums. It is used to print out the block names. But it does this by selecting blocks one by one. Is it possible to select all blocks and print the block names on their center points? I have very little knowledge of Autolisp. Is there anyone who can help with this?

 

(setq bn_txt nil)
(defun C:bn( / pt1 blname elast Newly_Created_Ent Obj_SS all_min all_max LL UR UL pt1);;;put temp variables
	(defun Last_Entity ( / Ent_Name Last_Ent)
	  (and
		(setq Last_Ent (entlast))
		(while (setq Ent_Name (entnext Last_Ent))
		  (setq Last_Ent Ent_Name)
		)
	  )
	  Last_Ent
	)
	(defun Ent_Created_by_Last_Command (Ent_Name / Ent_Next SS_Set)
	  (cond 
		( (not Ent_Name) (ssget "_X") )
		( (setq Ent_Next (entnext Ent_Name))
		  (setq SS_Set (ssadd Ent_Next))
		  (while (setq Ent_Next (entnext Ent_Next))
			(if (entget Ent_Next) (ssadd Ent_Next SS_Set))
		  )
		  SS_Set
		)
	  )
	)
	(if (null bn_txt)
		(progn
			(setvar "TEXTSIZE" (getdist "\Height of text label (uses default style): "))
			(setq bn_txt "sizeset")
		)
	)
	(princ "\nAdd block name to drawing.")
	(setq blname (vla-get-Effectivename (vlax-ename->vla-object (setq ent (car (entsel "\nSelect Block:"))))))
	(vlax-invoke (vlax-ename->vla-object ent) 'copy)
	(setq elast (Last_Entity))
	(command "explode" (entlast))
	(setq Newly_Created_Ent (ssadd))
	(setq Newly_Created_Ent (Ent_Created_by_Last_Command elast))
	(setq Obj_SS (ssadd))
	(foreach Ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex Newly_Created_Ent)))
		(if (not (wcmatch (vla-get-objectname (vlax-ename->vla-object Ent)) "*MText")) (ssadd Ent Obj_SS))
	)
	(setq	all_min	'() all_max	'())
	(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex Obj_SS))))
		(vla-GetBoundingBox ent 'minpt 'maxpt)
		(Setq all_min (cons (trans (vlax-safearray->list minpt) 1 0) all_min))
		(Setq all_max (cons (trans (vlax-safearray->list maxpt) 1 0) all_max))
	)
	(setq LL (list (car (vl-sort (mapcar 'car all_min) '<))
			   (car (vl-sort (mapcar 'cadr all_min) '<))
		 )
	)
	(setq UR (list (last (vl-sort (mapcar 'car all_max) '<))
			   (last (vl-sort (mapcar 'cadr all_max) '<))
		 )
	)
	(setq UL (list (car LL) (cadr UR)))
	(command "_.erase" Newly_Created_Ent "")
	(setq pt1 (getpoint"\nSelect center point for block title:"))
	(command "text" "c" pt1 "" "0" (strcat blname " / "  (rtos (distance UL UR) 2 1) "x" (rtos (distance LL UL) 2 1)))
	(princ)
)
(princ "\nType BN to execute.")

 

[BIGAL]

I may be wrong but seems overcomplicated for task. My only question is how many block names are we talking about ? So thinking more just use bedit and add block name to that block, all blocks of that name are done. Should be able to use a lisp in conjunction with bedit.

 

Pick block, get name of block, bedit

get bounding box of bedit block, then mid pt, compare to insert pt, ie add X & Y to work out mid pt

 text blockname newpt 

Save updated block

 

Hint mid point bounding box of selected block (setq mp (mapcar '* (mapcar '+ LL UR) '(0.5 0.5 0.5)))

 

It can be made to do all blocks that are currently displayed, or pick a few which would seem more appropriate, If you get stuck just ask for help.

 

Lee-mac.com has a get bounding box of multiple objects would return the LL UR for all the one block objects. 

[BIGAL]

Try this, there is some problems like some blocks are in a array so dont update as the initial get blk name skips them.

 

; https://www.cadtutor.net/forum/topic/74013-lisp-that-writes-block-names-to-the-center-of-the-block/

; By Gile
(defun remove_doubles (lst)
  (if lst
    (cons (car lst) (remove_doubles (vl-remove (car lst) lst)))
  )
)

;; Selection Set Bounding Box  -  Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; sel - [sel] Selection set for which to return bounding box

(defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
    (repeat (setq idx (sslength sel))
        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
        (if (and (vlax-method-applicable-p obj 'getboundingbox)
                 (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
            )
            (setq ls1 (cons (vlax-safearray->list llp) ls1)
                  ls2 (cons (vlax-safearray->list urp) ls2)
            )
        )
    )
    (if (and ls1 ls2)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
    )
)

(defun c:labelblk ( / txtsz ss bname lst2 ss2pts mp )
(setq txtsz (getreal "\nEnter text size"))
(setq ss (ssget (list (cons 0 "INSERT"))))

(setq lst '() lst2 '())
(repeat (setq x (sslength ss))
(setq bname (cdr (assoc 2 (entget  (ssname ss (setq x (1- x)))))))
(setq lst (cons bname lst))
)
(setq lst2 (remove_doubles lst))

(setvar 'filedia 0)
(foreach bname lst2
(command "-BEDIT" bname)
(setq ss2 (ssget "W"  (getvar 'extmin) (getvar 'extmax)))
(setq pts (LM:ssboundingbox ss2))
(setq mp (mapcar '* (mapcar '+ (car pts)(cadr pts) '(0.5 0.5))))
(command "TEXT" mp txtsz 0.0 bname)
(command "bclose" "")
(setvar 'filedia 1)
)

 

 

[bery35]

Quote

I may be wrong but seems overcomplicated for task. My only question is how many block names are we talking about ?

I have hundreds of blocks in my Autocad project. Let me give an example; Ventilation grills are named differently for each floor. Normal projects will have labels next to the grills, but not in this project. But inside the blocks, the dimensions of the culverts are written. I can count the names of the blocks with "bcount", but I cannot check their accuracy. For this reason, I want to proceed in a controlled way by printing the names of the blocks. You can see an example block naming in the picture below.

 

I tried the lispi you sent, but it gave the following error; "error: malformed list on input"

[mhupp]

This is what i use.

 

;;----------------------------------------------------------------------------;;
;; LABLE BLOCKS BY NAME MIDPOINT OF BOUNDINB BOX
  (defun C:BLKNAME (/ SS e Name LL UR MPT)
    (if (setq SS (ssget '((0 . "INSERT"))))
      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
        (setq Name (cdr (assoc 2 (entget e))))
        (vla-getboundingbox (vlax-ename->vla-object e) 'minpt 'maxpt)
        (setq LL (vlax-safearray->list minpt)
              UR (vlax-safearray->list maxpt)
              MPT (polar LL (angle LL UR) (/ (distance LL UR) 2))
        )
        (vl-cmdf "_.Text" "J" "MC" MPT "0.250" "0" Name)
      )
      (prompt "\nNo Blocks Selected")
    )
    (princ)
  )

 

add the following if you need diffrent text sizes

(setq txtsz (getreal "\nEnter text size"))
(vl-cmdf "_.Text" "J" "MC" MPT txtsz "0" Name)

 

[bery35]

Mhupp thank you lisp works very well. Exactly like I want. When I add the code you gave for text size and run it, I have to write the size value for each block one by one. Is it okay if it asks once at the beginning of the command?

[mhupp]

11 minutes ago, bery35 said:

Mhupp thank you lisp works very well. Exactly like I want. When I add the code you gave for text size and run it, I have to write the size value for each block one by one. Is it okay if it asks once at the beginning of the command?

 

Yes you can add it before the selection set if statement. this will make it only run once. Anything in the "foreach" will run on each block.

 

(defun C:BLKNAME (/ txtsz SS e Name LL UR MPT)
  (setq txtsz (getreal "\nEnter Text Size: "))
  (if (setq SS (ssget '((0 . "INSERT"))))

 

 

[bery35]

Thank you again Mhupp. I am attaching the final version of the code below, I tried it and it works.

 

;;----------------------------------------------------------------------------;;
;; LABLE BLOCKS BY NAME MIDPOINT OF BOUNDINB BOX
  (defun C:BLKNAME (/ txtsz SS e Name LL UR MPT)
  (setq txtsz (getreal "\nEnter Text Size: "))
  (if (setq SS (ssget '((0 . "INSERT"))))
      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
        (setq Name (cdr (assoc 2 (entget e))))
        (vla-getboundingbox (vlax-ename->vla-object e) 'minpt 'maxpt)
        (setq LL (vlax-safearray->list minpt)
              UR (vlax-safearray->list maxpt)
              MPT (polar LL (angle LL UR) (/ (distance LL UR) 2))
        )
(vl-cmdf "_.Text" "J" "MC" MPT txtsz "0" Name)
      )
      (prompt "\nNo Blocks Selected")
    )
    (princ)
  )

 

[BIGAL]

When I copy and pasted I accidently left off last 2 lines, updated code above

 

(princ)

)

 

Had another look at your sample dwg and can be done way faster it appears that all your blocks have the insert point as a central point, so no need to work out a bounding box. The code next will match insert point to text point.

 

; https://www.cadtutor.net/forum/topic/74013-lisp-that-writes-block-names-to-the-center-of-the-block/
; By AlanH info@alanh.com.au NOV 2021

(defun AH:Text (pt hgt str lay)
 (entmakex (list (cons 0 "TEXT")
                 (cons 8 lay)
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 1  str))))
				 
				 
(defun c:labelblk2 ( / txtsz ss bname lay)

(command "-layer" "M" "BLKTXT" "")
(setq lay "BLKTXT")

(setq txtsz (getreal "\nEnter text size "))

(setq ss (ssget (list (cons 0 "INSERT"))))

(repeat (setq x (sslength ss))
  (setq ent (entget  (ssname ss (setq x (1- x)))))
  (setq bname (cdr (assoc 2 ent)))
  (setq inspt (cdr (assoc 10 ent)))
  (AH:Text inspt 50 bname lay)
)

(princ)
)

(c:labelblk2)

 

 

[bery35]

Thank you Bigal, the first lisp you wrote was beautiful. This last code you sent does not change when I change the font.

[BIGAL]

Maybe try adding (cons 7 "textstylename") wntmake with out it is probably using "Standard"

[webster]

Sorry to resurrect a very old thread. I am having trouble with this code.

I am only getting a "0" at the block's base point.

 

Is there something I am doing wrong? I have copied the lisp exactly as per below. 

 

Also, how do I embed this into the block itself?  I would appreciate the help.

 

;;----------------------------------------------------------------------------;;
;; LABLE BLOCKS BY NAME MIDPOINT OF BOUNDINB BOX
  (defun C:BLKNAME (/ txtsz SS e Name LL UR MPT)
  (setq txtsz (getreal "\nEnter Text Size: "))
  (if (setq SS (ssget '((0 . "INSERT"))))
      (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
        (setq Name (cdr (assoc 2 (entget e))))
        (vla-getboundingbox (vlax-ename->vla-object e) 'minpt 'maxpt)
        (setq LL (vlax-safearray->list minpt)
              UR (vlax-safearray->list maxpt)
              MPT (polar LL (angle LL UR) (/ (distance LL UR) 2))
        )
(vl-cmdf "_.Text" "J" "MC" MPT txtsz "0" Name)
      )
      (prompt "\nNo Blocks Selected")
    )
    (princ)
  )

 

[BIGAL]

Ok a simple answer, its your text style that is the problem. When using a text style with a preset height you don't need the height.

(vl-cmdf "_.Text" "J" "MC" MPT txtsz "0" Name) ; with text height set to zero

(vl-cmdf "_.Text" "J" "MC" MPT "0" Name) ; with text height preset

 

So try with text style set to say Standard and height = 0.0, you could add this at start of defun.

 

(setvar 'textsyle "Standard")

 

[webster]

Thank you for that. 

 

Any way to integrate the is text into the block so it is all 1 selectable item?

[BIGAL]

You could add a attribute as block name, seems simplest way you decide where it goes.