Topic: Extract a block from a block to the same location

[Tharwat]

hello everyone .

Is it possible to extract a block from a block and inserted in the same location  ?

Or insert the same block from a block on its location to allow me to copy and paste them in the same location into another drawing .

Thanks in advance for any input .

[Lee Mac]

Is it possible to extract a block from a block and inserted in the same location  ?

Are you looking to extract a nested block from a block?

[Lee Mac]

This was an interesting program to write; even if it doesn't suit your task, hopefully someone else will benefit from it 

The program will 'extract' a nested block, converting it to a primary block in the same position, with the same scale and rotation as the selected nested reference.

This has similar functionality to NCOPY, however NCOPY will not work on nested blocks and furthermore this program will remove the nested block from the primary block definition.

Code - Auto/Visual Lisp: [Select]

1. ;; Extract Nested Block  -  Lee Mac 2012
2. ;; Converts a selected nested block into a primary block
3.  
4. (defun c:enb ( / doc lst sel )    
5.    (while
6.        (progn (setvar 'ERRNO 0) (setq sel (nentselp "\nSelect Nested Block: "))
7.            (cond
8.                (   (= 7 (getvar 'ERRNO))
9.                    (princ "\nMissed, try again.")
10.                )
11.                (   (or (null sel) (cadr (cadddr sel)))
12.                    nil
13.                )
14.                (   (princ "\nObject is not a Nested Block: "))
15.            )
16.        )
17.    )
18.    (if sel
19.        (progn
20.            (setq doc (vla-get-activedocument (vlax-get-acad-object))
21.                  lst (mapcar 'vlax-ename->vla-object (last sel))
22.            )
23.            (vla-transformby
24.                (vla-insertblock
25.                    (if (vlax-method-applicable-p doc 'objectidtoobject32)
26.                        (vla-objectidtoobject32 doc (vla-get-ownerid32 (last lst)))
27.                        (vla-objectidtoobject   doc (vla-get-ownerid   (last lst)))
28.                    )
29.                    (vlax-3D-point '(0.0 0.0 0.0))
30.                    (vla-get-name (car lst)) 1.0 1.0 1.0 0.0
31.                )
32.                (vlax-tmatrix (caddr sel))
33.            )
34.            (vla-delete (car lst))
35.            (vla-regen doc acactiveviewport)
36.        )
37.    )
38.    (princ)
39. )
40. (vl-load-com) (princ)

Example:

In this example, Block1 (green) is nested within Block2 (yellow), which is nested within Block3 (red). To make things a little more complex, at each level of the nesting, the references have been scaled and rotated.

[Lee Mac]

Here is another version of the above code; although not as concise, this version will retain all properties of the nested block when extracted:

Code - Auto/Visual Lisp: [Select]

1. ;; Extract Nested Block  -  Lee Mac 2012
2. ;; Converts a selected nested block into a primary block
3.  
4. (defun c:enb ( / doc lst obj sel )    
5.     (while
6.         (progn (setvar 'ERRNO 0) (setq sel (nentselp "\nSelect Nested Block: "))
7.             (cond
8.                 (   (= 7 (getvar 'ERRNO))
9.                     (princ "\nMissed, try again.")
10.                 )
11.                 (   (or (null sel) (cadr (cadddr sel)))
12.                     nil
13.                 )
14.                 (   (princ "\nObject is not a Nested Block: "))
15.             )
16.         )
17.     )
18.     (if sel
19.         (progn
20.             (setq doc (vla-get-activedocument (vlax-get-acad-object))
21.                   lst (mapcar 'vlax-ename->vla-object (last sel))
22.                   obj (car
23.                           (vlax-invoke doc 'copyobjects (list (car lst))
24.                               (if (vlax-method-applicable-p doc 'objectidtoobject32)
25.                                   (vla-objectidtoobject32 doc (vla-get-ownerid32 (last lst)))
26.                                   (vla-objectidtoobject   doc (vla-get-ownerid   (last lst)))
27.                               )
28.                           )
29.                       )
30.             )
31.             (vla-put-insertionpoint obj (vlax-3D-point '(0.0 0.0 0.0)))
32.             (vla-put-rotation obj 0.0)
33.             (vla-put-xscalefactor obj 1.0)
34.             (vla-put-yscalefactor obj 1.0)
35.             (vla-put-zscalefactor obj 1.0)
36.             (vla-put-normal obj (vlax-3D-point '(0.0 0.0 1.0)))
37.             (vla-transformby obj (vlax-tmatrix (caddr sel)))
38.             (vla-delete (car lst))
39.             (vla-regen doc acactiveviewport)
40.         )
41.     )
42.     (princ)
43. )
44. (vl-load-com) (princ)

[Tharwat]

Hi Lee .

Many thanks for your hard work on the thread . 

Both routines gave me the same result (error) ;

Command: enb
Select Nested Block: ; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception

My thoughts were to make a selection set of blocks and check every Block for a specific block name (one or two blocks) and insert
the same block(s) in the same location in Model space to be able later on to make another selection set of these blocks and move
them to another drawing with the same base point .

The hard part of the routine for me is that the translation of coordinates from Block Definition to model Space .

Thanks a lot

[Lee Mac]

Both routines gave me the same result (error) ;

Command: enb
Select Nested Block: ; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception

That's weird since I didn't get any errors when testing them before posting - are you maybe using dynamic blocks or have locked layers?

Anyone else getting errors?

[Tharwat]

No , I am not using dynamic block and not on locked layer either , but maybe due to OS is 64 ? just a guess .
because the code stopped at the function vla-get-ownerid when I tried to check where the error took a place .

Thanks

[Lee Mac]

No , I am not using dynamic block and not on locked layer either , but maybe due to OS is 64 ?

Ah yes! That would explain it 

I have modified the above posts with updated code, please give them a try 

[Tharwat]

No , I am not using dynamic block and not on locked layer either , but maybe due to OS is 64 ?

Ah yes! That would explain it 

I have modified the above posts with updated code, please give them a try 

OMG , the same result 

[Lee Mac]

OMG , the same result 

Oops! I forgot the corresponding ObjectIDtoObject32 method - above posts updated again 

[Tharwat]

I am very embarrassed with this error with my cad 2009 .
so I brought a copy of simple block if you interested to take a look .

Many thanks

[Lee Mac]

lol, don't be embarassed, its my code that failing 

Your example block works fine on my machine; do the above modified programs still error for you?

[Tharwat]

Tried it , but the same .

Hope you take a look at the attached video and I attached it in winrar folder because I don't know how to convert it to .gif to show it
directly in the forum as well as you do .

Many thanks

[Lee Mac]

My apologies for wasting your time Tharwat, I've just noticed my simple mistake: 'objectidtoobject32' is a method, not a property like 'ownerid32', so I should have used vlax-method-applicable-p over vlax-property-available-p. I think modified things a little too hastily earlier..

Please try the above modified code if you get a chance 

[Tharwat]

My apologies for wasting your time Tharwat, I've just noticed my simple mistake: 'objectidtoobject32' is a method, not a property like 'ownerid32', so I should have used vlax-method-applicable-p over vlax-property-available-p. I think modified things a little too hastily earlier..

Please try the above modified code if you get a chance 

Yeah ... now it is perfect 

So can we make it with ssget function for multiple selection set and getting them all within one base point ?

Thank you so much .

[Lee Mac]

Yeah ... now it is perfect 

Excellent 

So can we make it with ssget function for multiple selection set and getting them all within one base point ?

This task is not possible using ssget as it requires a subentity selection; however, the change to the Block Definition will be reflected across all Block References, so it may be better to have the code extract the nested block for all references - I'll see what I can do when I get some time. 

[Kerry]

Good evolution Lee

[Lee Mac]

Good evolution Lee

Thanks Kerry 

[kruuger]

this is birliant Lee
code is very usefull.
hats off
kruuger

[Lee Mac]

this is birliant Lee
code is very usefull.
hats off
kruuger

Thanks Kruuger! 

[Lee Mac]

however, the change to the Block Definition will be reflected across all Block References, so it may be better to have the code extract the nested block for all references - I'll see what I can do when I get some time. 

I finally got around to implementing this extension, the final code is posted here:

http://www.theswamp.org/index.php?topic=41414.0

[ahsattarian]

Have a look at this routine below.
It copies Line from inside Block into Current Space.

Code - Auto/Visual Lisp: [Select]

1. (defun c:ncopyline ()
2.   (while t
3.     (setq g 1)
4.     (while (= g 1)
5.       (while (null (setq es (nentselp "\r Select Line : "))))
6.       (setq s (car es))
7.       (setq en (entget s '("*")))
8.       (setq typ (strcase (cdr (assoc 0 en)) t))
9.       (cond ((= typ "line") (setq g 0)))
10.     )
11.     (setq en (entget s '("*")))
12.     (setq po1 (cdr (assoc 10 en)))
13.     (setq po2 (cdr (assoc 11 en)))
14.     (setq li (list po1 po2))
15.     (foreach s (cadddr es)
16.       (setq en (entget s '("*")))
17.       (setq po (cdr (assoc 10 en)))
18.       (setq scx (cdr (assoc 41 en)))
19.       (setq scy (cdr (assoc 42 en)))
20.       (setq scz (cdr (assoc 43 en)))
21.       (setq ang (cdr (assoc 50 en)))
22.       (setq ocs (cdr (assoc 210 en)))
23.       (setq method1 2)
24.       (cond
25.         ((= method1 1) ;|  Written by  :  Lee Mac  |;
26.          (defun mxv (m v) (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m))
27.          (defun trp (m) (apply 'mapcar (cons 'list m)))
28.          (defun mxm (m n) ((lambda (a) (mapcar '(lambda (r) (mxv a r)) m)) (trp n)))
29.          (setq li1 '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0)))
30.          (setq li2 (list (list (cos ang) (- (sin ang)) 0.0) (list (sin ang) (cos ang) 0.0) '(0.0 0.0 1.0)))
31.          (setq li3 (list (list scx 0.0 0.0) (list 0.0 scy 0.0) (list 0.0 0.0 scz)))
32.          (setq mat (mxm (mapcar '(lambda (v) (trans v 0 ocs t)) li1) (mxm li2 li3)))
33.          (setq li4 (mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 en)))))))
34.          (setq rfg (list mat (mapcar '- (trans (cdr (assoc 10 en)) ocs 0) li4)))
35.          (setq li (apply (function (lambda (m v) (mapcar (function (lambda (p) (mapcar '+ (mxv m p) v))) li))) rfg))
36.         )
37.         ((= method1 2) ;|  Written by  :  Amir Hossein Sattarian  |;
38.          (setq li (mapcar '(lambda (pt) (mapcar '* pt (list scx scy scz))) li))
39.          (setq li (mapcar '(lambda (pt) (polar '(0 0 0) (+ ang (angle '(0 0 0) pt)) (distance '(0 0 0) pt))) li))
40.          (setq li (mapcar '(lambda (pt) (mapcar '+ pt po)) li))
41.          (setq li (mapcar '(lambda (pt) (trans pt ocs 0)) li))
42.         )
43.       )
44.     )
45.     (setvar "cmdecho" 0)
46.     (command "line" (trans (car li) 0 1) (trans (cadr li) 0 1) "")
47.     (command "pselect" "last" "")
48.     (princ)
49.   )
50. )

[mhupp]

Another way.

Added a prompt if the user doesn't select a line it will display a message to try again letting the user knows whats going on.
Instead of using trans just add the block base point to the end points of the selected line with mapcar.
Also the (While t is and endless loop so you have to hit esc to exit. below you just stop selecting things to end the command.

Looking at lee mac's code this doesn't take into account the block X Y Z scaling.

Code - Auto/Visual Lisp: [Select]

1. ;;----------------------------------------------------------------------------;;
2. ;; Copy Lines From Inside a Block to Model Space
3. (defun c:CopyBlockLines (/ ss g es en typ blk pt1 pt2)
4.   (setq ss (ssadd))
5.   (while (setq es (nentsel "\nSelect Line: "))
6.     (setq g 1)
7.     (while (= g 1)
8.       (if es
9.         (setq en (entget (car es)))
10.       )
11.       (setq typ (cdr (assoc 0 en)))
12.       (cond
13.         ((= typ "LINE")
14.           (setq g 0)
15.         )
16.         (t
17.           (prompt "Not a Line Pick again")
18.           (setq es (nentsel "\nSelect Line: "))
19.         )
20.       )
21.     )
22.     (setq blk (last (last es)))
23.     (if (setq BP (cdr (assoc 10 (entget blk))))
24.       (progn
25.         (setq PT1 (mapcar '+ BP (cdr (assoc 10 en))))
26.         (setq PT2 (mapcar '+ BP (cdr (assoc 11 en))))
27.       )
28.       (setq PT1 (cdr (assoc 10 en)))
29.       (setq PT1 (cdr (assoc 11 en)))
30.     )
31.     (entmake (list (cons 0 "LINE") (cons 10 pt1) (cons 11 pt2)))
32.     (ssadd (entlast) ss)
33.     (sssetfirst nil ss)
34.   )
35.   (princ)
36. )

[Lee Mac]

@mhupp, you might find this to be an easier method -

Code - Auto/Visual Lisp: [Select]

1. (defun c:copyblocklines ( / l )
2.     (if (setq l (nentselp "\nSelect line: "))
3.         (vla-transformby (vlax-ename->vla-object (entmakex (entget (car l)))) (vlax-tmatrix (caddr l)))
4.     )
5.     (princ)
6. )
7. (vl-load-com) (princ)