Help needed with modification of block extraction lisp

March 12, 2023

The attached lisp selects all blocks named "TEST" in the drawing and writes a line with coordinates (Y, X) for each one in a txt file. Can someone help with a modification that will add the attributes values after the coordinates, for example:

Now it's: Y,X (one line for each block)

Should be: Y,X,Material att value,Year att value,Status att value (one line for each block)

Thanks in advance!

extbl.lsp Test_extbl.dwg

March 13, 2023

Before every one jumps in just Google "Extract attributes Autocad lisp" you will be swamped with answers there should be one that matches X&Y plus attributes.

Another is do above but make a table of answers.

Another is make a table or output to excel a count of Blocks including seperated by name and Attribute values,

eg

Door,Black,820,2100,10

Door,Black,780,2100,3

Lastly no need for a file can write to a excel direct.

Almost forgot use DATEXTRACTION built in function.

Edited March 13, 2023 by BIGAL

March 13, 2023

It's a easy addition to this code.

I know that DATEXTRACTION is built in, but I always write custom functions, just to have a 1 command, no extra questions asked .

I put the attribute order as the order is in the block. To get a different order you can redefine the block with BATTMAN (block attribute manager)

;; @FILE extract data of blocks with blockname "TEST".  Extract coordinates and attribute values.

;;;==================================================

(vl-load-com) ; initialization 

;;;==================================================

;; Get Attribute Values  -  Lee Mac
;; Returns an association list of attributes present in the supplied block.
;; blk - [ent] Block (Insert) Entity Name
;; Returns: [lst] Association list of ((<tag> . <value>) ... )
;; http://www.lee-mac.com/attributefunctions.html#algetattributevaluerc
(defun LM:getattributevalues ( blk / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (cons
            (cons
                (cdr (assoc 2 enx))
                (cdr (assoc 1 (reverse enx)))
            )
            (LM:getattributevalues blk)
        )
    )
)

;;;==================================================

(defun getcoords ( en / coordslst )
  (setq coordslst (list))
  (setq enlst (entget en))
  (foreach x enlst
    (if (= (car x) 10)
      (setq coordslst (append coordslst (list (cdr x))))
    ) ; end if
  ) ; end foreach
 coordslst
)

;;;==================================================


(defun c:extbl (/ fname file)
  (setq fname "D:/extbl.txt")
  (setq file (open fname "w"))
  (cgblock)
  (close file)  
  (startapp "notepad.exe" fname)
) ;_ end of defun


;;;======================CGBLOCK============================


(defun cgblock (/ lst ss i en obj tags atts att atts_vals title)
  (setq ss (ssget "X"
          '((0 . "INSERT") (2 . "TEST"); object Name
           )
          ) 
        )
		
	  (setq title "X, Y")	;; the first line of the data, we write the attribute tags
	  ;; extract the TAG names of the attributes.  We'll read them from the first block (ssname ss 0)
	  (setq atts (LM:getattributevalues (ssname ss 0)))
	  (foreach att atts
		(setq title (strcat title ", " (car att)))
	  )
	  (write-line title file)
	  (write-line "" file)  ;; extra blank line
		
        
  (repeat (setq i (sslength ss))
    (setq en  (ssname ss (setq i (1- i)))
      obj (vlax-ename->vla-object en)
    )

      ;----
	  

      (setq lst (getcoords en))
      (setq idx 0)
      (setq xy "")
      (repeat (length lst)
		(setq atts (LM:getattributevalues en))
		
		(setq atts_vals "")
		(foreach att atts
			(setq atts_vals (strcat atts_vals "," (cdr att)))
		)
	  
        (setq xy (strcat xy (rtos (cadr (nth idx lst)) 2 8) "," (rtos (car (nth idx lst)) 2 8) " "))

        (setq idx (+ 1 idx))
      )
      (write-line (strcat (vl-string-trim ", " xy) atts_vals) file)

      ;----

    )

) ;_ end of defun 'cgblock'


(princ "\nEnter Command EXTBL to extract the blocks data")
(princ)

Edited March 13, 2023 by Emmanuel Delay

March 13, 2023

4 hours ago, Emmanuel Delay said:

It's a easy addition to this code.

I know that DATEXTRACTION is built in, but I always write custom functions, just to have a 1 command, no extra questions asked .

I put the attribute order as the order is in the block. To get a different order you can redefine the block with BATTMAN (block attribute manager)

;; @FILE extract data of blocks with blockname "TEST".  Extract coordinates and attribute values.

;;;==================================================

(vl-load-com) ; initialization 

;;;==================================================

;; Get Attribute Values  -  Lee Mac
;; Returns an association list of attributes present in the supplied block.
;; blk - [ent] Block (Insert) Entity Name
;; Returns: [lst] Association list of ((<tag> . <value>) ... )
;; http://www.lee-mac.com/attributefunctions.html#algetattributevaluerc
(defun LM:getattributevalues ( blk / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (cons
            (cons
                (cdr (assoc 2 enx))
                (cdr (assoc 1 (reverse enx)))
            )
            (LM:getattributevalues blk)
        )
    )
)

;;;==================================================

(defun getcoords ( en / coordslst )
  (setq coordslst (list))
  (setq enlst (entget en))
  (foreach x enlst
    (if (= (car x) 10)
      (setq coordslst (append coordslst (list (cdr x))))
    ) ; end if
  ) ; end foreach
 coordslst
)

;;;==================================================


(defun c:extbl (/ fname file)
  (setq fname "D:/extbl.txt")
  (setq file (open fname "w"))
  (cgblock)
  (close file)  
  (startapp "notepad.exe" fname)
) ;_ end of defun


;;;======================CGBLOCK============================


(defun cgblock (/ lst ss i en obj tags atts att atts_vals title)
  (setq ss (ssget "X"
          '((0 . "INSERT") (2 . "TEST"); object Name
           )
          ) 
        )
		
	  (setq title "X, Y")	;; the first line of the data, we write the attribute tags
	  ;; extract the TAG names of the attributes.  We'll read them from the first block (ssname ss 0)
	  (setq atts (LM:getattributevalues (ssname ss 0)))
	  (foreach att atts
		(setq title (strcat title ", " (car att)))
	  )
	  (write-line title file)
	  (write-line "" file)  ;; extra blank line
		
        
  (repeat (setq i (sslength ss))
    (setq en  (ssname ss (setq i (1- i)))
      obj (vlax-ename->vla-object en)
    )

      ;----
	  

      (setq lst (getcoords en))
      (setq idx 0)
      (setq xy "")
      (repeat (length lst)
		(setq atts (LM:getattributevalues en))
		
		(setq atts_vals "")
		(foreach att atts
			(setq atts_vals (strcat atts_vals "," (cdr att)))
		)
	  
        (setq xy (strcat xy (rtos (cadr (nth idx lst)) 2 8) "," (rtos (car (nth idx lst)) 2 8) " "))

        (setq idx (+ 1 idx))
      )
      (write-line (strcat (vl-string-trim ", " xy) atts_vals) file)

      ;----

    )

) ;_ end of defun 'cgblock'


(princ "\nEnter Command EXTBL to extract the blocks data")
(princ)

Thank you very much @Emmanuel Delay. It works perfect but I made a stupid mistake: I said Y,X,att1,att2,att3,etc values but it should be: att1,Y,X,att2,att3,etc. I'm sorry, it was a dum mistake. If you can help with this modification I would greatly appreciate (even if I clearly don't deserve it).

March 13, 2023

Emmanuel a couple of suggestions, maybe a different approach.

I think just wants insertion point of block no need for co-ordinates function use, (cdr (assoc 10 (entget (car (entsel

No need to worry about tagnames (setq att (vla-get-attributes then just use (foreach att get the text value of Atrributes retrieved in creation order or as you mention can change the order

So

Get insertion point

get atts

make list att1

make list X Y

make list rest of atts

write line

March 14, 2023

8 hours ago, BIGAL said:

Emmanuel a couple of suggestions, maybe a different approach.

I think just wants insertion point of block no need for co-ordinates function use, (cdr (assoc 10 (entget (car (entsel

No need to worry about tagnames (setq att (vla-get-attributes then just use (foreach att get the text value of Atrributes retrieved in creation order or as you mention can change the order

So

Get insertion point

get atts

make list att1

make list X Y

make list rest of atts

write line

Yeah, I adapted current code; I didn't touch what already works

March 14, 2023

Like this?

So first the material, then X,Y, then the rest.

;; @FILE extract data of blocks with blockname "TEST".  Extract coordinates and attribute values.
(vl-load-com) ; initialization 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; read attributes

;; Get Attribute Value  -  Lee Mac
;; Returns the value held by the specified tag within the supplied block, if present.
;; blk - [vla] VLA Block Reference Object
;; tag - [str] Attribute TagString
;; Returns: [str] Attribute value, else nil if tag is not found.
(defun LM:vl-getattributevalue ( blk tag )
    (setq tag (strcase tag))
    (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun export2file (data / fname file)
	(setq fname "C:/extbl.txt")
	(setq file (open fname "w"))
	;; whrite all lines
	(foreach line data
		(write-line line file)
	)
	(close file)  
	(startapp "notepad.exe" fname)
) ;_ end of defun

(defun c:extbl ( / ss i en obj data ip line_str material year status )
	;; Select the blocks
	(setq ss (ssget "X"
	  '((0 . "INSERT") (2 . "TEST"); object Name
	   )
	  ) 
	)
	
	(setq data (list))  ;; list of lines to be exported
	(setq i 0)
	(repeat (sslength ss)
		(setq en  (ssname ss i)
		  obj (vlax-ename->vla-object en)
		)
		;; read coordinates
		(setq ip (cdr (assoc 10 (entget en))))
		;; read attributes
		(setq material (LM:vl-getattributevalue obj "MATERIAL"))
		(setq year (LM:vl-getattributevalue obj "YEAR"))
		(setq status (LM:vl-getattributevalue obj "STATUS"))
		(princ "\n")
		;; assemble the line
		(setq line_str (strcat
			material ","
			(rtos (nth 0 ip) 2 10) ","	;; 10 is the number of digits.  Feel free to change the value
			(rtos (nth 1 ip) 2 10) ","
			year ","
			status
		))
		(setq data (append data (list line_str )))
		(setq i (+ i 1))
	)
	;; export all
	(export2file data)
	(princ)
)

Edited March 14, 2023 by Emmanuel Delay

March 15, 2023

On 3/14/2023 at 9:42 AM, Emmanuel Delay said:

Like this?

So first the material, then X,Y, then the rest.

;; @FILE extract data of blocks with blockname "TEST".  Extract coordinates and attribute values.
(vl-load-com) ; initialization 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; read attributes

;; Get Attribute Value  -  Lee Mac
;; Returns the value held by the specified tag within the supplied block, if present.
;; blk - [vla] VLA Block Reference Object
;; tag - [str] Attribute TagString
;; Returns: [str] Attribute value, else nil if tag is not found.
(defun LM:vl-getattributevalue ( blk tag )
    (setq tag (strcase tag))
    (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun export2file (data / fname file)
	(setq fname "C:/extbl.txt")
	(setq file (open fname "w"))
	;; whrite all lines
	(foreach line data
		(write-line line file)
	)
	(close file)  
	(startapp "notepad.exe" fname)
) ;_ end of defun

(defun c:extbl ( / ss i en obj data ip line_str material year status )
	;; Select the blocks
	(setq ss (ssget "X"
	  '((0 . "INSERT") (2 . "TEST"); object Name
	   )
	  ) 
	)
	
	(setq data (list))  ;; list of lines to be exported
	(setq i 0)
	(repeat (sslength ss)
		(setq en  (ssname ss i)
		  obj (vlax-ename->vla-object en)
		)
		;; read coordinates
		(setq ip (cdr (assoc 10 (entget en))))
		;; read attributes
		(setq material (LM:vl-getattributevalue obj "MATERIAL"))
		(setq year (LM:vl-getattributevalue obj "YEAR"))
		(setq status (LM:vl-getattributevalue obj "STATUS"))
		(princ "\n")
		;; assemble the line
		(setq line_str (strcat
			material ","
			(rtos (nth 0 ip) 2 10) ","	;; 10 is the number of digits.  Feel free to change the value
			(rtos (nth 1 ip) 2 10) ","
			year ","
			status
		))
		(setq data (append data (list line_str )))
		(setq i (+ i 1))
	)
	;; export all
	(export2file data)
	(princ)
)

Unfortunately it's not working here and I suspect it's because I am using progecad. Amost all lisps work but some don't. The output on the example DWG is:

,173.7358975462,270.5328228437,,
,171.8763198752,271.2749462108,,
,170.0505328888,272.2332572907,,

And it returns a "error: too few arguments" error after it opens the file. There are 9 such errors so one for each attribute in the 3 blocks in example file.

Anyway, thank you very much for your work, I really appreciate it.

Edited March 15, 2023 by Radu Iordache

March 15, 2023

Oh wait ...

(setq fname "C:/extbl.txt")

Set it back to

(setq fname "D:/extbl.txt") or (setq fname "D:\\extbl.txt")

But I don't know if that fixes the problem.

March 15, 2023

2 minutes ago, Emmanuel Delay said:

Oh wait ...

(setq fname "C:/extbl.txt")

Set it back to

(setq fname "D:/extbl.txt") or (setq fname "D:\\extbl.txt")

But I don't know if that fixes the problem.

No, it doesn't. It creates the output with all the commas, but leaves blank the attribute values, as shown above. It's probably the progecad limitation with one of the functions.

March 16, 2023

See if this works.

I took out all visual LISP (no vl-, no vla- ...), just left vanilla LISP

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Get Attribute Values  -  Lee Mac
;; Returns an association list of attributes present in the supplied block.
;; blk - [ent] Block (Insert) Entity Name
;; Returns: [lst] Association list of ((<tag> . <value>) ... )
;; http://www.lee-mac.com/attributefunctions.html#algetattributevaluerc
(defun LM:getattributevalues ( blk / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (cons
            (cons
                (cdr (assoc 2 enx))
                (cdr (assoc 1 (reverse enx)))
            )
            (LM:getattributevalues blk)
        )
    )
)

;; get a specific value; given the result of LM:getattributevalues
(defun getAttributeValue ( attributevalues tag / res att)
	(foreach att attributevalues
		(if (= tag (car att))
			(setq res (cdr att))
		)
	)
	res
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun export2file (data / fname file)
	(setq fname "D:/extbl.txt")
	(setq file (open fname "w"))
	;; whrite all lines
	(foreach line data
		(write-line line file)
	)
	(close file)  
	(startapp "notepad.exe" fname)
) ;_ end of defun

(defun c:extbl ( / ss i en obj data ip line_str attributes material year status )
	;; Select the blocks
	(setq ss (ssget "X"
	  '((0 . "INSERT") (2 . "TEST"); object Name
	   )
	  ) 
	)
	
	(setq data (list))  ;; list of lines to be exported
	(setq i 0)
	(repeat (sslength ss)
		(setq en  (ssname ss i)
		  obj (vlax-ename->vla-object en)
		)
		;; read coordinates
		(setq ip (cdr (assoc 10 (entget en))))
		;; read attributes
		(setq attributes (LM:getattributevalues en))
		
		(setq material (getAttributeValue attributes "MATERIAL"))
		(setq year (getAttributeValue attributes "YEAR"))
		(setq status (getAttributeValue attributes "STATUS"))
		
		(princ "\n")
		;; assemble the line
		(setq line_str (strcat
			material ","
			(rtos (nth 0 ip) 2 10) ","
			(rtos (nth 1 ip) 2 10) ","
			year ","
			status
		))
		(setq data (append data (list line_str )))
		(setq i (+ i 1))
	)
	;; export all
	(export2file data)
	(princ)
)

Edited March 16, 2023 by Emmanuel Delay

March 16, 2023

3 hours ago, Emmanuel Delay said:

See if this works.

I took out all visual LISP (no vl-, no vla- ...), just left vanilla LISP

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Get Attribute Values  -  Lee Mac
;; Returns an association list of attributes present in the supplied block.
;; blk - [ent] Block (Insert) Entity Name
;; Returns: [lst] Association list of ((<tag> . <value>) ... )
;; http://www.lee-mac.com/attributefunctions.html#algetattributevaluerc
(defun LM:getattributevalues ( blk / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (cons
            (cons
                (cdr (assoc 2 enx))
                (cdr (assoc 1 (reverse enx)))
            )
            (LM:getattributevalues blk)
        )
    )
)

;; get a specific value; given the result of LM:getattributevalues
(defun getAttributeValue ( attributevalues tag / res att)
	(foreach att attributevalues
		(if (= tag (car att))
			(setq res (cdr att))
		)
	)
	res
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun export2file (data / fname file)
	(setq fname "D:/extbl.txt")
	(setq file (open fname "w"))
	;; whrite all lines
	(foreach line data
		(write-line line file)
	)
	(close file)  
	(startapp "notepad.exe" fname)
) ;_ end of defun

(defun c:extbl ( / ss i en obj data ip line_str attributes material year status )
	;; Select the blocks
	(setq ss (ssget "X"
	  '((0 . "INSERT") (2 . "TEST"); object Name
	   )
	  ) 
	)
	
	(setq data (list))  ;; list of lines to be exported
	(setq i 0)
	(repeat (sslength ss)
		(setq en  (ssname ss i)
		  obj (vlax-ename->vla-object en)
		)
		;; read coordinates
		(setq ip (cdr (assoc 10 (entget en))))
		;; read attributes
		(setq attributes (LM:getattributevalues en))
		
		(setq material (getAttributeValue attributes "MATERIAL"))
		(setq year (getAttributeValue attributes "YEAR"))
		(setq status (getAttributeValue attributes "STATUS"))
		
		(princ "\n")
		;; assemble the line
		(setq line_str (strcat
			material ","
			(rtos (nth 0 ip) 2 10) ","
			(rtos (nth 1 ip) 2 10) ","
			year ","
			status
		))
		(setq data (append data (list line_str )))
		(setq i (+ i 1))
	)
	;; export all
	(export2file data)
	(princ)
)

It works perfectly!!! @Emmanuel Delay, thank you so much, I really appreciate the time you took to help me! Really nice of you, mate!

Sign In

Help needed with modification of block extraction lisp

Recommended Posts

Radu Iordache

BIGAL

Emmanuel Delay

Radu Iordache

BIGAL

Emmanuel Delay

Emmanuel Delay

Radu Iordache

Emmanuel Delay

Radu Iordache

Emmanuel Delay

Radu Iordache

Join the conversation

Tutorials

Forums

Activity