LISP to explode block and make block again with the same name

[karpki]

Hi,

Need LISP to automate such action: explode selected (by clicking) block and make block again with the same name and from same primitives.

The aim is to lose all the attributes and dynamic parameters from the block.

Of caurse any other ideas without exploding welcome! 

All I have found - Undynamic.lsp few versions and multitasker bgtools.lsp aren't doing it the way I need. 

Thanks in advance! 

[hak_vz]

test

[hak_vz]

Try this code that removes attributes from blocks. Can add removal of dynamic parameters.

(defun c:removeBlockAttributes nil (removeBlockAttributes))

(defun removeBlockAttributes ( / file f lst dcl_id sel remove_Attribute getblocks string_to_list)
	(defun remove_Attribute (blockname)
	(setq acad (vlax-get-acad-object) doc (vla-get-activedocument acad))
	 (cond
		((tblsearch "BLOCK" blockname)
			(setq blk (vla-item (vla-get-blocks doc) blockname))
			(vlax-for item blk
				(if (= (vlax-get item 'ObjectName) "AcDbAttributeDefinition")(vla-delete item))
			)
		)
		(T (princ (strcat "\nBlock with name " blockname " don't exist in this drawing >")))
	 )
	)
	(defun getblocks (/ adoc name lst)
	  (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
	  (vlax-for blk (vla-get-blocks adoc)
		;; Exclude model and paper spaces, xref and anonymus blocks
		(if (and  (equal (vla-get-IsLayout blk) :vlax-false)
				  (equal (vla-get-IsXref blk) :vlax-false)
				  (/= (substr (vla-get-Name blk) 1 1) "*")) 
			 (setq lst (cons (vla-get-Name blk) lst))
		  ) 
		) 
	  lst
	)
	 (defun string_to_list ( str del / pos )
        (if (setq pos (vl-string-search del str))
            (cons (substr str 1 pos) (string_to_list (substr str (+ pos 1 (strlen del))) del))
            (list str)
        )
    )
	(setq file (vl-filename-mktemp "blocks.dcl"))
	(setq f (open file "w"))
	(write-line "test: dialog {:row {:list_box {label = \"Remove attributes from block\"; key = \"blocks\";fixed_width = true;width = 20;height = 12;multiple_select = true; } } ok_cancel; }" f)
	(close f)
	
	(setq lst (getblocks))
	
	(setq dcl_id (load_dialog file))
	(if (not (new_dialog "test" dcl_id)) (exit))
	(start_list "blocks" 3)
	(mapcar 'add_list lst)
	(end_list)
	(action_tile "accept" "(setq sel (get_tile \"blocks\"))(done_dialog)")
	(start_dialog)
	(done_dialog dcl_id)
	(unload_dialog dcl_id)
	(cond 
		((and sel)
			(setq sel (mapcar 'atoi (string_to_list sel " ")))
			
			(foreach index sel (remove_Attribute (nth index lst)))

		)
	)
	(princ "\nDone!")
)

[karpki]

Hi, thanks bro, but unfortunatelly it doesn't work. Attributes are still there after command activated. ACad 2020. File is enclosed

[karpki]

By the way, this LISP offers to switch the stop mode, I don't know what does it mean but both choices YES or NO makes nothing with the choosen block. The log from command line looks like this:

[hak_vz]

After I tested your sample, none of them have attributes in them. This code removes attributes from block definitions, you have to reinsert INSERTS into a drawing.

[karpki]

Indeed! If delete the block and insert again than yes, atributes are gone. 

Anyway rescpect! But issue not solved, sorry!

I have normally hundred of blocks in the drawing.

How the ordinar drawing looks like:

And the aim is to

1. select block by clicking! (without finding needed name in the list with hundred blocks).

2 push the button.  

[hak_vz]

After you reset initial block use command ATTSYNC

Use this command to update instances of blocks containing attributes that were redefined using the BLOCK or BEDIT commands. ATTSYNC does not change any values assigned to attributes in existing blocks.

Note: ATTSYNC removes any format or property changes made with the ATTEDIT or EATTEDIT commands. It also deletes any extended data associated with the block, and might affect dynamic blocks and blocks created by third-party applications.
The following prompts are displayed.

[karpki]

It is clear, yes, thank you!

But what do you think if to go easier way in the LISP logic:

1. Select block

2. Get name

3. Explode

4. Select same primitives

5. Make a new block with the old name

Is it real or unreal challenge?

[marko_ribar]

First of all, I have to step in... Once ATTRIBUTE is added to BLOCK, there is no way you can restore it to the state it was before - without flag (66 . 1)... BLOCK is permanently polluted... Yes you can EXPLODE and recreate and be avare that you should firstly choose block with 0.0 rotation and 1 1 1 scale factors and store it's insertion point in variable so when recreating you pick exactly the same spot, but you SHOULDN'T do it that way, as, when you redefine block (CAD will ask if the name is the same Yes/No) all other References will still have attributes attached to them - there is actually no relation between references and definition... So my only advice is that you go with @hak_vz method and (vla-delete) all both "AcDbAttributeDefinition" from block collection of definitions and "AcDbAttribute" from coresponding references - all of ATTRIBUTES (for each ATTRIBUTE you have to remove single "AcDbAttributeDefinition" from block definition and all "AcDbAttribute" from all INSERT references of that same block)... Then you should do ATTSYNC, but still blocks will be polluted : you will get DXF data similar to this :

(
(-1 . <Entity name: 20fc4d099e0>)
(0 . "INSERT")
(330 . <Entity name: 20fb6aa41f0>)
(5 . "24E")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(100 . "AcDbBlockReference")
(66 . 1)
(2 . "x")
(10 26.205 13.2273 0.0)
(41 . 1.0)
(42 . 1.0)
(43 . 1.0)
(50 . 0.0)
(70 . 0)
(71 . 0)
(44 . 0.0)
(45 . 0.0)
(210 0.0 0.0 1.0)
)

(
(-1 . <Entity name: 20fc4d09a10>)
(0 . "SEQEND")
(330 . <Entity name: 20fc4d099e0>)
(5 . "251")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(-2 . <Entity name: 20fc4d099e0>)
)

All in all, you will remove attrubutes and clean references, but only partially - like I said, DXF data will stay polluted...

So to conclude, you'll have to collect all block names - iterate through definition block collection and gather names and store it in list... Iterate through blocks and for each block remove "AcDbAttributeDefinition"s : (vlax-for o (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) "blockname") (if (= (vla-get-objectname o) "AcDbAttributeDefinition") (vla-delete o)) )... Then select all references of that block (ssget "_:L" '((0 . "INSERT") (66 . 1) (2 . "blockname"))), then : (vlax-for r (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))) (vlax-for o (append (vlax-invoke r 'getconstantattributes) (vlax-invoke r 'getattributes)) (vla-delete o) ) )

Finally you ATTSYNC...

[marko_ribar]

One more thing to add...

When you remove all attributes from references and definitions and you leave polluted only geometry blocks, you can never add once again new attributes to those blocks (references and definitions) - pollution is unreparable...

[hak_vz]

@karpki 

In his post @marko_ribar has given detailed descriprion of how things work regarding working with blocks, so I won't give further explanations.

[marko_ribar · Accepted solution]

@karpki 

I've found a way to remove all attributes from all blocks and for block (name) you pick... This is of course without polluting blocks as they are reinserted over existing ones that have attributes...

(defun c:remallatt-allblks ( / RefGeom trp mxm mxv adoc cl bl tmat rg )

  (vl-load-com)

  ;; RefGeom (gile)
  ;; Returns a list which first item is a 3x3 transformation matrix (rotation,
  ;; scales, normal) and second item the object insertion point in its parent
  ;; (xref, block or space)
  ;;
  ;; Argument : an ename

  (defun RefGeom ( ename / elst ang norm mat )
      (setq elst (entget ename)
            ang  (cdr (assoc 50 elst))
            norm (cdr (assoc 210 elst))
      )
      (list
          (setq mat
              (mxm
                  (mapcar '(lambda ( v ) (trans v 0 norm t))
                     '(
                          (1.0 0.0 0.0)
                          (0.0 1.0 0.0)
                          (0.0 0.0 1.0)
                      )
                  )
                  (mxm
                      (list
                          (list (cos ang) (- (sin ang)) 0.0)
                          (list (sin ang) (cos ang)     0.0)
                         '(0.0 0.0 1.0)
                      )
                      (list
                          (list (cdr (assoc 41 elst)) 0.0 0.0)
                          (list 0.0 (cdr (assoc 42 elst)) 0.0)
                          (list 0.0 0.0 (cdr (assoc 43 elst)))
                      )
                  )
              )
          )
          (mapcar '- (trans (cdr (assoc 10 elst)) norm 0)
              (mxv mat (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst))))))
          )
      )
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix

  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )

  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices

  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )

  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n

  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (vlax-for b (vla-get-blocks (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
    (if
      (and
        (= (vla-get-isxref b) :vlax-false)
        (= (vla-get-isdynamicblock b) :vlax-false)
      )
      (vlax-for o b
        (if (= (vla-get-objectname o) "AcDbAttributeDefinition")
          (vla-delete o)
        )
      )
    )
  )
  (setq cl (getvar 'clayer))
  (ssget "_X" (list '(0 . "INSERT") '(66 . 1) (cons 410 (vla-get-name (vla-get-activelayout adoc)))))
  (vlax-for r (vla-get-activeselectionset adoc)
    (if (/= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (vla-get-layer r))))))
      (progn
        (setvar 'clayer (vla-get-layer r))
        (setq bl (vla-insertblock (vla-get-block (vla-get-activelayout adoc)) (vlax-3d-point '(0.0 0.0 0.0)) (vla-get-name r) 1.0 1.0 1.0 0.0))
        (setq tmat (append (mapcar '(lambda ( x y ) (append x (list y))) (car (setq rg (RefGeom (vlax-vla-object->ename r)))) (cadr rg)) '((0.0 0.0 0.0 1.0))))
        (vla-transformby bl (vlax-tmatrix tmat))
        (vla-delete r)
      )
    )
  )
  (setvar 'clayer cl)
  (princ)
)

(defun c:remallatt-blk ( / RefGeom trp mxm mxv adoc cl e bln bl tmat rg )

  (vl-load-com)

  ;; RefGeom (gile)
  ;; Returns a list which first item is a 3x3 transformation matrix (rotation,
  ;; scales, normal) and second item the object insertion point in its parent
  ;; (xref, block or space)
  ;;
  ;; Argument : an ename

  (defun RefGeom ( ename / elst ang norm mat )
      (setq elst (entget ename)
            ang  (cdr (assoc 50 elst))
            norm (cdr (assoc 210 elst))
      )
      (list
          (setq mat
              (mxm
                  (mapcar '(lambda ( v ) (trans v 0 norm t))
                     '(
                          (1.0 0.0 0.0)
                          (0.0 1.0 0.0)
                          (0.0 0.0 1.0)
                      )
                  )
                  (mxm
                      (list
                          (list (cos ang) (- (sin ang)) 0.0)
                          (list (sin ang) (cos ang)     0.0)
                         '(0.0 0.0 1.0)
                      )
                      (list
                          (list (cdr (assoc 41 elst)) 0.0 0.0)
                          (list 0.0 (cdr (assoc 42 elst)) 0.0)
                          (list 0.0 0.0 (cdr (assoc 43 elst)))
                      )
                  )
              )
          )
          (mapcar '- (trans (cdr (assoc 10 elst)) norm 0)
              (mxv mat (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst))))))
          )
      )
  )

  ;; Matrix Transpose  -  Doug Wilson
  ;; Args: m - nxn matrix

  (defun trp ( m )
      (apply 'mapcar (cons 'list m))
  )

  ;; Matrix x Matrix  -  Vladimir Nesterovsky
  ;; Args: m,n - nxn matrices

  (defun mxm ( m n )
      ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  )

  ;; Matrix x Vector  -  Vladimir Nesterovsky
  ;; Args: m - nxn matrix, v - vector in R^n

  (defun mxv ( m v )
      (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  )

  (setq cl (getvar 'clayer))
  (prompt "\nPick block reference you want to remove all attributes from all other references with the same name...")
  (if (setq e (ssget "_+.:S:E" '((0 . "INSERT"))))
    (progn
      (setq bln (cdr (assoc 2 (entget (ssname e 0)))))
      (vlax-for b (vla-get-blocks (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
        (if
          (and
            (= (vla-get-isxref b) :vlax-false)
            (= (vla-get-isdynamicblock b) :vlax-false)
            (= (vla-get-name b) bln)
          )
          (vlax-for o b
            (if (= (vla-get-objectname o) "AcDbAttributeDefinition")
              (vla-delete o)
            )
          )
        )
      )
      (ssget "_X" (list '(0 . "INSERT") '(66 . 1) (cons 2 bln) (cons 410 (vla-get-name (vla-get-activelayout adoc)))))
      (vlax-for r (vla-get-activeselectionset adoc)
        (if (/= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (vla-get-layer r))))))
          (progn
            (setvar 'clayer (vla-get-layer r))
            (setq bl (vla-insertblock (vla-get-block (vla-get-activelayout adoc)) (vlax-3d-point '(0.0 0.0 0.0)) (vla-get-name r) 1.0 1.0 1.0 0.0))
            (setq tmat (append (mapcar '(lambda ( x y ) (append x (list y))) (car (setq rg (RefGeom (vlax-vla-object->ename r)))) (cadr rg)) '((0.0 0.0 0.0 1.0))))
            (vla-transformby bl (vlax-tmatrix tmat))
            (vla-delete r)
          )
        )
      )
    )
  )
  (setvar 'clayer cl)
  (princ)
)

[karpki]

Fantastic!

Is it possible to add erasing of dynamic paramters in this LISP ? 

[marko_ribar]

---

@karpki wrote:

Fantastic!

Is it possible to add erasing of dynamic paramters in this LISP ? 

---

It works only with static blocks and attributes attached to them... One notice - as new insertions are inserted and replace original blocks, you may loose XDATA, LDATA, hyperlinks attached to originals - that's drawback I see, but you will be able to add new attributes as blocks won't be polluted - they will be without (66 . 1) flag and behave like you inserted geometrical block data in old fashioned way... For dynamic blocks, I suggest that you set their visual style to desired, convert them to static blocks and perform those routines with them all along with ordinary static blocks all at once, once they're set up to be static w/o attributes...

[karpki]

Loosing the data is one of the aim cause it is too old or wrong. I need only geometric lines to save. All the other needed info lays in the block name and layer name. Thank you very much! 

I guess to earase dynamic data separate LISP is needed. Don't you have such ?

[marko_ribar · Accepted solution]

Here is what I have in my library that may be helpful for dynamic blocks...

;;
;; Convert dynamic blocks (in current visibility state) to static
;;
;; Routine: UnDynamic by MP Seagull - March 26, 2010
;; 
;; MODIFIED BY Lanny Schiele (aka 'HatchMaker Maker') - 10/27/2017
;;

(defun c:UnDynamic
    (   /
        _DefGetString
        _get_item
        _right
        _make_key
        _dynamic->static_block
        _get_locked
        _get_dynamic_inserts
        _main
    )

    (vl-load-com)

	;;;* GET STRING WITH DEFAULT
	(defun _DefGetString (prmpt default allowspace / d2)
	  (if allowspace
	    (setq
	      ans
	       (cond
	         ((not
	            (= (setq
	                 d2 (getstring T (strcat prmpt " <" default ">: "))
	               ) ;_ end of setq
	               ""
	            ) ;_ end of =
	          ) ;_ end of not
	          d2
	         )
	         (default)
	       ) ;_ end of cond
	    ) ;_ end of setq
	    (setq
	      ans
	       (cond
	         ((not
	            (= (setq d2 (getstring (strcat prmpt " <" default ">: ")))
	               ""
	            ) ;_ end of =
	          ) ;_ end of not
	          d2
	         )
	         (default)
	       ) ;_ end of cond
	    ) ;_ end of setq
	  ) ;_ end of if
	  ans
	) ;_ end of defun
  

    (defun _get_item ( collection key / item )
        (vl-catch-all-apply
           '(lambda ( ) (setq item (vla-item collection key)))
        )
        item
    )

    (defun _right ( str n / len )
        (if (< n (setq len (strlen str)))
            (substr str (1+ (- len n)))
            str
        )
    )

    (defun _make_key ( collection prefix len / key )
        (   (lambda ( i pad )
                (while
                    (_get_item collection
                        (setq key
                            (strcat prefix
                                (_right
                                    (strcat pad (itoa (setq i (1+ i))))
                                    len
                                )
                            )
                        )
                    )
                )
                key
            )
         ;;;0
            99999
            (   (lambda ( pad )
                    (while (< (strlen pad) len)
                        (setq pad (strcat "0" pad))
                    )
                    pad
                )
                ""
            )
        )
    )


    (defun _dynamic->static_block ( blocks insert len )
        (vla-ConvertToStaticBlock
            insert
            (_make_key blocks *UnDynamic:Prefix* len)
        )
    )


    (defun _get_locked ( layers / locked )
        (vlax-for layer layers
            (if (eq :vlax-true (vla-get-lock layer))
                (setq locked (cons layer locked))
            )
        )
        locked
    )


    (defun _get_dynamic_inserts ( blocks / block object inserts )
        (vlax-for block blocks
            (vlax-for object block
                (if (eq "AcDbBlockReference" (vla-get-objectname object))
                    (if (eq :vlax-true (vla-get-isdynamicblock object))
                        (setq inserts (cons object inserts))
                    )
                )
            )
        )
        inserts
    )
  

    (defun _get_dynamic_inserts_from_pickset ( ss / i object inserts )
        (setq i 0)
        (while (< i (sslength ss))
                (setq object (vlax-ename->vla-object (ssname ss i)))
                (if (eq "AcDbBlockReference" (vla-get-objectname object))
                    (if (eq :vlax-true (vla-get-isdynamicblock object))
                        (setq inserts (cons object inserts))
                    )
                )
                (setq i (1+ i))
        )
        inserts
    )


    (defun _main ( document / ss blocks inserts locked len )
        (if (not *UnDynamic:Prefix*)
          (setq *UnDynamic:Prefix* "STATIC_")
        )
        (if (and
              (setq blocks (vla-get-blocks document))
              (setq ss (ssget ":L" (list (cons 0 "INSERT"))))
              (setq inserts (_get_dynamic_inserts_from_pickset ss))
              (setq *UnDynamic:Prefix* (_DefGetString "\nPrefix for static block names" *UnDynamic:Prefix* T))
            )
;;;            (setq inserts
;;;                (_get_dynamic_inserts
;;;                    (setq blocks (vla-get-blocks document))
;;;                )
;;;            )
            
            (progn
;;;                (foreach layer (setq locked (_get_locked (vla-get-layers document)))
;;;                    (vla-put-lock layer :vlax-false)
;;;                )
;;;                (setq len (strlen (itoa (length inserts))))
                (setq len 6)
                (foreach insert inserts
                    (_dynamic->static_block blocks insert len)
                )
;;;                (foreach layer locked
;;;                    (vla-put-lock layer :vlax-true)
;;;                )
                (princ "\n...done.")
            )
            (princ "\nNo dynamic blocks found - no block inserts were changed.")
        )
        (princ)
    )

    (_main (vla-get-activedocument (vlax-get-acad-object)))

)

[karpki]

Well, this one I have already. It renames blocks with extra numbers. Unforunatelly! 

[karpki]

If it's possible to rebuild it so it will work with the only one picked block. Then yes....

But I think it is too difficult

[marko_ribar]

Here, I've coded quickly this one... Still not so sure about naming standards, but it's different... Test it and see if it's better now...

(defun c:undynamic-MR ( / addzeros adoc blnlst ss i bl bln blnlstassoc blnlstassoccounter k nstr )

  (vl-load-com)

  (defun addzeros ( l k )
    (if (< k l)
      (strcat "0" (addzeros (1- l) k))
      ""
    )
  )

  (alert "When asked to select blocks, you have to select all only once to make names counter renaming dynamic to static blocks correct... You can't select partially (firstly one sel. set and then with another starting of routine next sel. set...")
  (vlax-for b (vla-get-blocks (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
    (if
      (and
        (= (vla-get-isxref b) :vlax-false)
        (= (vla-get-isdynamicblock b) :vlax-true)
      )
      (setq blnlst (cons (vla-get-name b) blnlst))
    )
  )
  (if (setq ss (ssget "_:L" '((0 . "INSERT"))))
    (repeat (setq i (sslength ss))
      (setq bl (ssname ss (setq i (1- i))))
      (if (member (setq bln (vla-get-effectivename (vlax-ename->vla-object bl))) blnlst)
        (if (assoc bln blnlstassoc)
          (setq blnlstassoc (subst (cons bln (1+ (cdr (assoc bln blnlstassoc)))) (assoc bln blnlstassoc) blnlstassoc))
          (setq blnlstassoc (cons (cons bln 1) blnlstassoc))
        )
      )
    )
  )
  (repeat (setq i (sslength ss))
    (setq bl (ssname ss (setq i (1- i))))
    (setq bln (vla-get-effectivename (vlax-ename->vla-object bl)))
    (if (assoc bln blnlstassoccounter)
      (progn
        (setq blnlstassoccounter (subst (cons bln (1+ (cdr (assoc bln blnlstassoccounter)))) (assoc bln blnlstassoccounter) blnlstassoccounter))
        (setq k (cdr (assoc bln blnlstassoccounter)))
        (setq nstr (strcat (addzeros (strlen (itoa (cdr (assoc bln blnlstassoc)))) (strlen (itoa k))) (itoa k)))
        (vla-converttostaticblock (vlax-ename->vla-object bl) (strcat bln nstr))
      )
      (progn
        (setq blnlstassoccounter (cons (cons bln 1) blnlstassoccounter))
        (setq nstr (strcat (addzeros (strlen (itoa (cdr (assoc bln blnlstassoc)))) 1) (itoa 1)))
        (vla-converttostaticblock (vlax-ename->vla-object bl) (strcat bln nstr))
      )
    )
  )
  (princ)
)