Lisp routine to replace block with non block object

[Jest]

I need a lisp routine to replace selected block(s) with non block object.....such as closed polyline or mpolygon, and preserve block's object data table.......and vice versa.

Can somebody help?

[Trudy]

Attach .dwg file with that you want.

[tigcat]

replace with block and then explode  it 

[Jest]

On 10/16/2021 at 4:53 PM, tigcat said:

replace with block and then explode  it 

There is a major problem, because ...as I said...I want to preserve block's object data table. After exploding block (or "burst" it), OD are lost.

[BIGAL]

What is the problem just "GET" OD then explode, make new object and "PUT" OD to that object, Google there was some OD routines out there as a package to do this.

[Jest]

6 hours ago, BIGAL said:

What is the problem just "GET" OD then explode, make new object and "PUT" OD to that object, Google there was some OD routines out there as a package to do this.

I know how to copy OD from another object.... It's easy if you have a few objects to fix.
I have more than 8000 blocks with different object data values.
It would takes many, many hours to do this on this way.
There is "ReplaceBlock.vlx" routine I have found on net. It works well, but only with blocks....replace block by another block and preserves original OD...at once.
But, I need to replace thousands of blocks with non block object and preserve blocks OD.
I have searched a lot on Google, but I couldn't found what I need.
So I am asking for help.

Edited October 19, 2021 by Jest

[BIGAL]

It does not matter if its 1 or 8000 a ssget will get all 8000 then you process them 1 at a time. I did some testing on 25,000 items required in doing something creating 2500 objects yes it took 6 seconds. I can not see hours.

 

VLX is so you can not change the code.

 

Post a dwg and what code you have if its vlx do not post.

[Jest]

Unfortunately I have only vlx routine...I don't know where I found it. Maybe someone has a lisp code with same process....
But aniway....here is a sample dwg "Test", containing just a part of original drawing.
Block1, I want to replace, is on the Layer1 (green). It has OD table named "Tabela"
Block2 is on Layer2 (magenta), and non block object (mpolygon) is on Layer3 (red). Both are without OD.
Using vlx routine "ReplaceBlock" I can replace all Blocks1 with Block2 and preserve OD....fast and easy.
I want to do the same operation replacing Blocks1 with mpolygon (red).
Of course, routine should ask me to define insertion point on mpolygon.
And also, I wish to have an option to replace all blocks or just a selection.

ReplaceBlock.vlx Test.dwg

[mhupp]

This will replace selected blocks with a rectangle. Blocks with the same name will also be replaced even if they weren't selected. (just how blocks work)

Do you only want the selected blocks to change?

 

;;----------------------------------------------------------------------------;;
;; replace block with rectangle
(defun C:BLKREPLACE (/ SS blkname blklst obj ll ur rec)
  (setq SS (ssget '((0 . "INSERT"))))
  (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ;filters down to unique block names only.
    (if (vl-position (setq blkname (cdr (assoc 2 (entget e)))) blklst) 
      (ssdel e SS)
      (setq blklst (cons blkname blklst))
    )
  )
  (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))  ;after filter edits each block thats left
    (setq obj (vlax-ename->vla-object e))
    (vla-getboundingbox obj 'minpt 'maxpt)
    (setq LL (vlax-safearray->list minpt)
          UR (vlax-safearray->list maxpt)
    )
    (vl-cmdf "_.Rectangle" "_non" LL "_non" UR) 
    (setq rec (entlast))
    (setq SS1 (ssadd e))
    (sssetfirst nil SS1)
    (vl-cmdf "-REFEDIT" "O" "A" "N")
    (if (/= (getvar 'refeditname) "")  ;only runs erase all if in refedit mode
      (vl-cmdf "_.Erase" "All" "")
    )
    (vl-cmdf "_.Refset" "A" rec "")
    (vl-cmdf "_.Refclose" "S")
  )
)

 

 

[BIGAL]

I got the OD working by picking block1 then block2 to test the OD stuff. No VLX.

 

A Mpolygon is a sort of hybrid block which has a hatch and a pline outline, so my question is what do you want, as Mhupp suggested a rectang or just a hatch or some other single object, multi objects, a circle ? You need to really define that a bit clearer and can add.

 

; https://www.cadtutor.net/forum/topic/73848-lisp-routine-to-replace-block-with-non-block-object/

; By Alanh OCT 2020 info@alanh.com.au
; swap blocks but keep OD data


(DEFUN C:ODBLK ( / blk1 blk2 ss tabname fieldnames x y ent ent2 inspt fval)

(setq blk1 (entsel "\nPick 1st block for name OD data "))

(setq blk2 (entsel "\nPick 2nd block for replacement "))


; DO IF NOT BLOCK

(setq blkn (cdr (assoc 2 (entget (car blk1)))))
(setq blkn2 (cdr (assoc 2 (entget (car blk2)))))

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



(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (1- x))))
(setq tabname (ade_odgettables ent))

(setq fieldnames nil count 0)

(foreach Y (cdr (assoc "Columns" (ade_odtabledefn (nth count tabname))))
   (if (not (member (cdr (assoc "ColName" Y)) fieldnames))
    (setq fieldnames (cons (list (nth count tabname)(cdr (assoc "ColName" Y))(ade_odgetfield ent "Tabela" (cdr (assoc "ColName" Y)) 0)     ) fieldnames))
   )
)
  
  
(setq inspt (cdr (assoc 10 (entget ent))))
(entdel ent)
(command "-insert" blkn2 inspt 1 1 0)

(setq ent2 (entlast))
(ade_odaddrecord ent2 (nth 0 (nth 0 fieldnames)))
(foreach fval fieldnames
(ade_odsetfield ENT2  (nth 0 fval) (nth 1 fval) 0 (nth 2 fval))
)

)

(PRINC)
)

 

 

[Jest]

1 hour ago, BIGAL said:

I got the OD working by picking block1 then block2 to test the OD stuff. No VLX.

 

A Mpolygon is a sort of hybrid block which has a hatch and a pline outline, so my question is what do you want, as Mhupp suggested a rectang or just a hatch or some other single object, multi objects, a circle ? You need to really define that a bit clearer and can add.

 

; https://www.cadtutor.net/forum/topic/73848-lisp-routine-to-replace-block-with-non-block-object/

; By Alanh OCT 2020 info@alanh.com.au
; swap blocks but keep OD data


(DEFUN C:ODBLK ( / blk1 blk2 ss tabname fieldnames x y ent ent2 inspt fval)

(setq blk1 (entsel "\nPick 1st block for name OD data "))

(setq blk2 (entsel "\nPick 2nd block for replacement "))


; DO IF NOT BLOCK

(setq blkn (cdr (assoc 2 (entget (car blk1)))))
(setq blkn2 (cdr (assoc 2 (entget (car blk2)))))

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



(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (1- x))))
(setq tabname (ade_odgettables ent))

(setq fieldnames nil count 0)

(foreach Y (cdr (assoc "Columns" (ade_odtabledefn (nth count tabname))))
   (if (not (member (cdr (assoc "ColName" Y)) fieldnames))
    (setq fieldnames (cons (list (nth count tabname)(cdr (assoc "ColName" Y))(ade_odgetfield ent "Tabela" (cdr (assoc "ColName" Y)) 0)     ) fieldnames))
   )
)
  
  
(setq inspt (cdr (assoc 10 (entget ent))))
(entdel ent)
(command "-insert" blkn2 inspt 1 1 0)

(setq ent2 (entlast))
(ade_odaddrecord ent2 (nth 0 (nth 0 fieldnames)))
(foreach fval fieldnames
(ade_odsetfield ENT2  (nth 0 fval) (nth 1 fval) 0 (nth 2 fval))
)

)

(PRINC)
)

 

 

Closed polyline would be fine. I wish to draw polyline and then run command to replace blocks (all or selected) with this polyline.
Similar procedure like vlx routine I attached recently. Could you do that?

[Jest]

12 hours ago, mhupp said:

This will replace selected blocks with a rectangle. Blocks with the same name will also be replaced even if they weren't selected. (just how blocks work)

Do you only want the selected blocks to change?

 

;;----------------------------------------------------------------------------;;
;; replace block with rectangle
(defun C:BLKREPLACE (/ SS blkname blklst obj ll ur rec)
  (setq SS (ssget '((0 . "INSERT"))))
  (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ;filters down to unique block names only.
    (if (vl-position (setq blkname (cdr (assoc 2 (entget e)))) blklst) 
      (ssdel e SS)
      (setq blklst (cons blkname blklst))
    )
  )
  (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))  ;after filter edits each block thats left
    (setq obj (vlax-ename->vla-object e))
    (vla-getboundingbox obj 'minpt 'maxpt)
    (setq LL (vlax-safearray->list minpt)
          UR (vlax-safearray->list maxpt)
    )
    (vl-cmdf "_.Rectangle" "_non" LL "_non" UR) 
    (setq rec (entlast))
    (setq SS1 (ssadd e))
    (sssetfirst nil SS1)
    (vl-cmdf "-REFEDIT" "O" "A" "N")
    (if (/= (getvar 'refeditname) "")  ;only runs erase all if in refedit mode
      (vl-cmdf "_.Erase" "All" "")
    )
    (vl-cmdf "_.Refset" "A" rec "")
    (vl-cmdf "_.Refclose" "S")
  )
)

 

 

This lisp works strange on my PC. After selecting one block and hit enter...everything disappeared.
After a few Undo commands, I got all blocks back and rectangle around previous selected block. But previous block stays. And there is no OD in rectangle...??
I wish to choose all or selection of blocks with same name....And I want to select block by picking it, not writing its name.

[BIGAL]

If you look at Mhupp code a good learning lesson there is no reference to OD data that would need to be added. 

 

I will add the rectang based on the size of the "X", if you have OD blocks of various sizes then will need to do something else.

 

So version 2

 

; https://www.cadtutor.net/forum/topic/73848-lisp-routine-to-replace-block-with-non-block-object/

; By Alanh OCT 2020 info@alanh.com.au
; swap blocks but keep OD data


(DEFUN C:ODBLK ( / blk1 blk2 ss tabname fieldnames x y ent ent2 inspt fval)

(setq blk1 (entsel "\nPick 1st block for name OD data "))
(setq blkn (cdr (assoc 2 (entget (car blk1)))))

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

(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (1- x))))
(setq tabname (ade_odgettables ent))

(setq fieldnames nil count 0)

(foreach Y (cdr (assoc "Columns" (ade_odtabledefn (nth count tabname))))
   (if (not (member (cdr (assoc "ColName" Y)) fieldnames))
    (setq fieldnames (cons (list (nth count tabname)(cdr (assoc "ColName" Y))(ade_odgetfield ent "Tabela" (cdr (assoc "ColName" Y)) 0)     ) fieldnames))
   )
)
  
  
(setq inspt (cdr (assoc 10 (entget ent))))
(entdel ent)
(setq pt1 (mapcar '+ inspt (list -1.0 1.0 0.0))) 
(setq pt2 (mapcar '+ inspt (list 1.0 -1.0 0.0)))
(command "rectang" Pt1 pt2 )

(setq ent2 (entlast))

(ade_odaddrecord ent2 (nth 0 (nth 0 fieldnames)))

(foreach fval fieldnames
(ade_odsetfield ENT2  (nth 0 fval) (nth 1 fval) 0 (nth 2 fval))
)
)

(PRINC)
)

 

 

Edited October 21, 2021 by BIGAL

[Jest]

5 hours ago, BIGAL said:

If you look at Mhupp code a good learning lesson there is no reference to OD data that would need to be added. 

 

I will add the rectang based on the size of the "X", if you have OD blocks of various sizes then will need to do something else.

 

So version 2

 

; https://www.cadtutor.net/forum/topic/73848-lisp-routine-to-replace-block-with-non-block-object/

; By Alanh OCT 2020 info@alanh.com.au
; swap blocks but keep OD data


(DEFUN C:ODBLK ( / blk1 blk2 ss tabname fieldnames x y ent ent2 inspt fval)

(setq blk1 (entsel "\nPick 1st block for name OD data "))
(setq blkn (cdr (assoc 2 (entget (car blk1)))))

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

(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (1- x))))
(setq tabname (ade_odgettables ent))

(setq fieldnames nil count 0)

(foreach Y (cdr (assoc "Columns" (ade_odtabledefn (nth count tabname))))
   (if (not (member (cdr (assoc "ColName" Y)) fieldnames))
    (setq fieldnames (cons (list (nth count tabname)(cdr (assoc "ColName" Y))(ade_odgetfield ent "Tabela" (cdr (assoc "ColName" Y)) 0)     ) fieldnames))
   )
)
  
  
(setq inspt (cdr (assoc 10 (entget ent))))
(entdel ent)
(setq pt1 (mapcar '+ inspt (list -1.0 1.0 0.0))) 
(setq pt2 (mapcar '+ inspt (list 1.0 -1.0 0.0)))
(command "rectang" Pt1 pt2 )

(setq ent2 (entlast))

(ade_odaddrecord ent2 (nth 0 (nth 0 fieldnames)))

(foreach fval fieldnames
(ade_odsetfield ENT2  (nth 0 fval) (nth 1 fval) 0 (nth 2 fval))
)
)

(PRINC)
)

 

 

It works fine, but... I need rectangle 0,5x0,5m size, not 2x2m.
Can you fix lisp, so I can define length of rectangle side by entering value?

[BIGAL]

Its your turn to start learning look at

 

(setq pt1 (mapcar '+ inspt (list -1.0 1.0 0.0)))

 

in explanation (setq pt1 (mapcar '+ inspt  (list X Y Z))) add  X Y Z to the point inspt XYZ.

 

[Jest]

11 hours ago, BIGAL said:

Its your turn to start learning look at

 

(setq pt1 (mapcar '+ inspt (list -1.0 1.0 0.0)))

 

in explanation (setq pt1 (mapcar '+ inspt  (list X Y Z))) add  X Y Z to the point inspt XYZ.

 

Yes, you are right.... I have to learn something more...I am just a beginner  on lisp region and have a big problem. Thanks for the first lesson.
I must ask you for one more service. My block is on different layers and I want to put squares on the same layers and color, not just on current layer.
And .... There is one strange thing happened while testing. There was a single line starting from the center of one block (not a part of a block).
I normally selected all blocks (not that line) and run command. All blocks was replaced OK, except block with line from the center.
It was converted to polyline with 1 vertex and 0 length with OD data. Any idea what is happening?
I have a big drawing and thousands of blocks, so I am afraid to lose some blocks, which are touched with some objects.

 

Hi again.
I have found out what causes the problem... Osnap ON setting. It must be turned OFF
Maybe you should put Osnap off command at the beginning of lisp routine...?

Edited October 22, 2021 by Jest

[BIGAL]

Last answer 1st (setvar 'osmode 16384) turns off osnap

 

(defun....
(setq oldsanp (getvar 'osmode))
(setvar 'osmode 16384)
.... all the code 

(setvar 'osmode oldsnap)
(princ)
) ; end of defun

 

Part 2

(setq blk1 (entsel "\nPick 1st block for name OD data "))
(setvar 'clayer (cdr (assoc 8 (entget (car blk1))))) ; sets layer to blk layer
(setq col (cdr (assoc 62 (entget (car blk1))))) ; gets color

 

Part 3  easiest way is CHPROP add after making the rectang

(command "chprop" (entlast) "" "C" col "")

 

All blocks was replaced OK, except block post a sample dwg, need to look at it.

 

You will get lots more help if you have a go at coding and obviously you learn at same time, when it does not work just ask for help.

[Jest]

17 hours ago, BIGAL said:

Last answer 1st (setvar 'osmode 16384) turns off osnap

 

(defun....
(setq oldsanp (getvar 'osmode))
(setvar 'osmode 16384)
.... all the code 

(setvar 'osmode oldsnap)
(princ)
) ; end of defun

 

Part 2

(setq blk1 (entsel "\nPick 1st block for name OD data "))
(setvar 'clayer (cdr (assoc 8 (entget (car blk1))))) ; sets layer to blk layer
(setq col (cdr (assoc 62 (entget (car blk1))))) ; gets color

 

Part 3  easiest way is CHPROP add after making the rectang

(command "chprop" (entlast) "" "C" col "")

 

All blocks was replaced OK, except block post a sample dwg, need to look at it.

 

You will get lots more help if you have a go at coding and obviously you learn at same time, when it does not work just ask for help.

Thank you...
I could manage the part 1.
I am not quite sure where exactly to put part 2 and 3...I've tried, but I couldn't make it..still put all rectangles on current layer.
I will be able to do that, when learning more about creating lisps....right now, unfortunately,  I don't have time for that.
You could learn me more if you fix existing lisp, and then I could compare differences.
I have tried to modify some lisps before, without learning the basics....just knowing command lines.... Sometimes it works, but most of them....
the problem always appears at the moment to decide in which line exactly should put command to modify lisp.

Obviously it is not so simple..
Anyway...I could handle this lisp by executing process on each layer separately...after all, there are just five of them.
Thank you again for your help.. I admire your skill....I don't want to bother you no more.
Kind regards

[BIGAL]

Try this size is set to 0.2.

 

; https://www.cadtutor.net/forum/topic/73848-lisp-routine-to-replace-block-with-non-block-object/

; By Alanh OCT 2020 info@alanh.com.au
; swap blocks but keep OD data


(DEFUN C:ODBLK ( / blk1 blk2 ss tabname fieldnames x y ent ent2 inspt fval)
(setq oldlay (getvar 'clayer))
(setq blk1 (entsel "\nPick 1st block for name OD data "))
(setq blkn (cdr (assoc 2 (entget (car blk1)))))
(setvar 'clayer (cdr (assoc 8 (entget (car blk1))))) ; sets layer to blk layer
(setq col (cdr (assoc 62 (entget (car blk1))))) ; gets color
(setq ss (ssget (list (cons 0 "INSERT")(cons 2 blkn))))

(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (1- x))))
(setq tabname (ade_odgettables ent))

(setq fieldnames nil count 0)

(foreach Y (cdr (assoc "Columns" (ade_odtabledefn (nth count tabname))))
   (if (not (member (cdr (assoc "ColName" Y)) fieldnames))
    (setq fieldnames (cons (list (nth count tabname)(cdr (assoc "ColName" Y))(ade_odgetfield ent "Tabela" (cdr (assoc "ColName" Y)) 0)     ) fieldnames))
   )
)
  
  
(setq inspt (cdr (assoc 10 (entget ent))))
(entdel ent)
(setq pt1 (mapcar '+ inspt (list -0.2 0.2 0.0))) 
(setq pt2 (mapcar '+ inspt (list 0.2 -0.2 0.0)))
(command "rectang" Pt1 pt2 )
(command "chprop" (entlast) "" "C" col "")
(setq ent2 (entlast))

(ade_odaddrecord ent2 (nth 0 (nth 0 fieldnames)))

(foreach fval fieldnames
(ade_odsetfield ENT2  (nth 0 fval) (nth 1 fval) 0 (nth 2 fval))
)
)
(setvar 'clayer oldlay)
(PRINC)
)

 

[Jest]

11 hours ago, BIGAL said:

Try this size is set to 0.2.

 

; https://www.cadtutor.net/forum/topic/73848-lisp-routine-to-replace-block-with-non-block-object/

; By Alanh OCT 2020 info@alanh.com.au
; swap blocks but keep OD data


(DEFUN C:ODBLK ( / blk1 blk2 ss tabname fieldnames x y ent ent2 inspt fval)
(setq oldlay (getvar 'clayer))
(setq blk1 (entsel "\nPick 1st block for name OD data "))
(setq blkn (cdr (assoc 2 (entget (car blk1)))))
(setvar 'clayer (cdr (assoc 8 (entget (car blk1))))) ; sets layer to blk layer
(setq col (cdr (assoc 62 (entget (car blk1))))) ; gets color
(setq ss (ssget (list (cons 0 "INSERT")(cons 2 blkn))))

(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (1- x))))
(setq tabname (ade_odgettables ent))

(setq fieldnames nil count 0)

(foreach Y (cdr (assoc "Columns" (ade_odtabledefn (nth count tabname))))
   (if (not (member (cdr (assoc "ColName" Y)) fieldnames))
    (setq fieldnames (cons (list (nth count tabname)(cdr (assoc "ColName" Y))(ade_odgetfield ent "Tabela" (cdr (assoc "ColName" Y)) 0)     ) fieldnames))
   )
)
  
  
(setq inspt (cdr (assoc 10 (entget ent))))
(entdel ent)
(setq pt1 (mapcar '+ inspt (list -0.2 0.2 0.0))) 
(setq pt2 (mapcar '+ inspt (list 0.2 -0.2 0.0)))
(command "rectang" Pt1 pt2 )
(command "chprop" (entlast) "" "C" col "")
(setq ent2 (entlast))

(ade_odaddrecord ent2 (nth 0 (nth 0 fieldnames)))

(foreach fval fieldnames
(ade_odsetfield ENT2  (nth 0 fval) (nth 1 fval) 0 (nth 2 fval))
)
)
(setvar 'clayer oldlay)
(PRINC)
)

 

Still not working on different layers.
It puts all rectangles on layer of selected OD source block...see video.
OD table data is OK. It is correct transformed from each replaced block.
I wish this could work regardeles of the OD table name. In this case it is "Tabela". If I use this lisp for any other OD table name,
I should correct name in lisp first. Otherwise it will copy OD Table, but puts data fields blank.