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

[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)