LISP for Block Data

[andelo523]

Hey folks,

Okay, so I have an Assignment to get Sheet Part Dimensions from DXF Files to Calculate Prices etc.

What I've done so far, I have converted the DXF Files do DWG, for which I have a LISP to insert all DWG Files into one File, so I can work with it easier.

For the next step I would need a LISP that extracts Block names with the maximum Block extents in the following Format:

"BLOCKNAME / DIMENSION1xDIMENSION2". After that I can use the Data Extraction function to insert the Data to Excel, where I can calculate the Area, Weight, and whatever is needed.

I allready got a nice little LISP, that puts out the Block name as Text, and it works perfectly. Maybe someone can modify it, and add the dimensions to it?

(setq bn_txt nil)
(defun C:BN( / pt1 blname)
(if (null bn_txt)
(progn
(setvar "TEXTSIZE" (getdist "\Height of text label (uses default 
style): "))
(setq bn_txt "sizeset")
) ; end progn
) ; end if
(princ "\nAdd block name to drawing.")
(setq blname (cdr (assoc 2 (entget (car (entsel"\nSelect Block:"))))))
(setq pt1 (getpoint"\nSelect center point for block title:"))
(command "text" "c" pt1 "" "0" blname)
)
(princ "\nType BN to execute.")

[dbhunia]

Try Like this.......

(setq bn_txt nil)
(defun C:DV( / pt1 Dim_Val)
	(if (null bn_txt)
		(progn
		(setvar "TEXTSIZE" (getdist "\Height of text label (uses default style): "))
		(setq bn_txt "sizeset")
		) ; end progn
	) ; end if
	(princ "\nAdd Dimension Value to drawing.")
	(if (not (wcmatch (vla-get-ObjectName (setq obj (vlax-ename->vla-object (car(entsel "\nSelect Dimension: "))))) "*Dimension"))
		(princ "\n** Object Must be a Dimension **")
		(progn
			(setq Dim_Val (strcat 
							(vla-get-TextPrefix obj)
							(rtos (vla-get-Measurement obj)
								  (vla-get-UnitsFormat obj)
								  (vla-get-PrimaryUnitsPrecision obj)
							)
							(vla-get-TextSuffix obj)
						  )
			)
			(setq pt1 (getpoint"\nSelect point to write Dimension Value:"))
			(command "text" "c" pt1 "" "0" Dim_Val)
		)
	)	
(princ)
)
(princ "\nType DV to execute.")

[andelo523]

Hi,

That's not really what I had in Mind. I need something like this (See Picture).

When I Klick the Block it puts out the Name, and the Dimensions in one Text String.

[dbhunia]

Try this.......

(setq bn_txt nil)
(defun C:BN( / pt1 blname Dim_Val ent T_W acdoc)
	(if (null bn_txt)
		(progn
			(setvar "TEXTSIZE" (getdist "\Height of text label (uses default style): "))
			(setq bn_txt "sizeset")
		) ; end progn
	) ; end if
	(princ "\nAdd block name to drawing.")
	(setq blname (cdr (assoc 2 (entget (car (entsel"\nSelect Block:"))))))
	(setq T_W "")
	(setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
	(vlax-for each (vla-item (vla-get-blocks acdoc) blname)
				(if (wcmatch (vla-get-objectname each) "*Dimension")
					(progn
						(setq Dim_Val (strcat 
									(vla-get-TextPrefix each)
									(rtos (vla-get-Measurement each)
										  (vla-get-UnitsFormat each)
										  (vla-get-PrimaryUnitsPrecision each)
									)
									(vla-get-TextSuffix each)
								  )
						)
						(setq T_W (strcat T_W Dim_Val "x"))
					)
				)
	 )	
	(setq pt1 (getpoint"\nSelect center point for block title:"))
	(command "text" "c" pt1 "" "0" (strcat blname "/" (vl-string-right-trim "x" T_W)))
)
(princ "\nType BN to execute.")

[andelo523]

Quite nice, we almost got it..

Can you make it that it doesn't need Dimensions?

Like this...

[dbhunia]

Add the Blue line.......

	(vlax-for each (vla-item (vla-get-blocks acdoc) blname)
				(if (wcmatch (vla-get-objectname each) "*Dimension")
					(progn
						(setq Dim_Val (strcat 
									(vla-get-TextPrefix each)
									(rtos (vla-get-Measurement each)
										  (vla-get-UnitsFormat each)
										  (vla-get-PrimaryUnitsPrecision each)
									)
									(vla-get-TextSuffix each)
								  )
						)
						(vla-delete each)
						(setq T_W (strcat T_W Dim_Val "x"))
					)
				)
	 )	

[andelo523]

No, it's not good.

Your Function strictly requires Dimensions from the Start. I've meant, could the Function not require any Dimensions at all, so I don't have to draw any extra dimensions?

[dbhunia]

Try this........

If your Block is not rotated & unit is Decimal.......

(princ "\nType BN to execute.")
(setq bn_txt nil)
(defun C:BN( / pt1 blname);;;put temp variables
	(if (null bn_txt)
		(progn
			(setvar "TEXTSIZE" (getdist "\Height of text label (uses default style): "))
			(setq bn_txt "sizeset")
		) ; end progn
	) ; end if
	(princ "\nAdd block name to drawing.")
	(setq blname (cdr (assoc 2 (entget (setq ent (car (entsel"\nSelect Block:")))))))
	(vla-getBoundingBox (setq obj (vlax-ename->vla-object ent)) 'll 'ur)
	(setq LL (vlax-safearray->list ll))
	(setq UR (vlax-safearray->list ur))
	(setq UL (list (car LL) (cadr UR)))
	(setq pt1 (getpoint"\nSelect center point for block title:"))
	(command "text" "c" pt1 "" "0" (strcat blname "/" (rtos (distance LL UL) 2 0) "x" (rtos (distance UL UR) 2 0)))
)
(princ "\nType BN to execute.")

[andelo523]

This one basically works, but has a few issues.

- The Blocks musst have a 0,0 Basepoint in order to have good values because it measures from that Point. Thats not the case in every Block I have.

- Second, if a Text border is streched over the Contour, the LISP also measures to that border because that's it's extent which is logical.

I think in order to solve the Problem, first I will need another LISP that moves every single Block to 0,0 . Second, it will require to limit the function to only geometry elements, and leave the Text out.

[dbhunia]

About your 1st point.....the Base Point of block must be inside the block, that may be any value....

For your 2nd point...... Until I check your Blocks in Drawing file, I can not say anything.....

So you post a sample Drawing explaining Requirements then we will talk:)

[andelo523]

Okay, here are the Files.

Base Sample - The Blocks that I have put in one Drawing

End Result - Additional Text that Contains the Required Information (Block Name / Dim1xDim2)

The LISP should get these informations from the Blocks, then I can use them for Data Extraction to Excel.

Thanks in advance!

[dbhunia]

check this.......

(setq bn_txt nil)
(defun C:BN( / pt1 blname);;;put temp variables
	(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 (cdr (assoc 2 (entget (setq ent (car (entsel"\nSelect Block:")))))))
        (setq blname (vla-get-Effectivename (vlax-ename->vla-object (setq ent (car (entsel "\nSelect Block:"))))))
	(setq Obj_SS (ssadd))
	(setq Expl_Blk_Ent (vlax-invoke (vlax-ename->vla-object ent) 'explode))
	(foreach obj Expl_Blk_Ent
		(if (not (wcmatch (vla-get-objectname obj) "*MText")) (ssadd (vlax-vla-object->ename obj) 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)))
	(foreach obj Expl_Blk_Ent (vla-delete obj))
	(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.")

[andelo523]

It worked on most parts, but on some parts it gives me crazy dimension values (see picture).

Can you fix that?

[dbhunia]

What should I do with this picture?.......................

Always post Drawing ....... so that anyone can check what is the fact behind any problems.......

Also you check your Blocks in details ....... so that you also find out the problems......

[andelo523]

Here is the Drawing with a few more blocks..

I can't find out any Problem because I don't know anything about LISP programing. But I'm trying to learn the basics at the moment.

[dbhunia · Accepted solution]

Check 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.")

[andelo523]

Yes! I think you got it now.. It works very good.. 👍 👍 👍

Thank you very much!