Topic: Split block crossing by polyline it's possible with lisp?

[LULU1965]

Split block crossing by polyline it's possible with lisp?

[roy_043]

Posting the same problem in two forums seems to have become the new standard.
http://www.cadtutor.net/forum/showthread.php?99247-Split-block-crossing-by-polyline-it-s-possible-with-lisp

[ribarm]

I answered there :

And new reply...

[xdcad]

Destroying the original object is not a better way, nor is it universal
You can use the CLIP method of INSERT to create XCLIP


code see:
http://www.theswamp.org/index.php?topic=58796.0

[ribarm]

Are you creating 2 blocks from 1?
I thought that WIPEOUT will be just enough, just it has to have as boudary 2 parallel polylines connected from bottom and top side... Block should remain untouched with same look...

[xdcad]

Are you creating 2 blocks from 1?
I thought that WIPEOUT will be just enough, just it has to have as boudary 2 parallel polylines connected from bottom and top side... Block should remain untouched with same look...

The original poster did not mean to dig out a strip in the middle.
But a line divides the two parts

[ribarm]

Are you creating 2 blocks from 1?
I thought that WIPEOUT will be just enough, just it has to have as boudary 2 parallel polylines connected from bottom and top side... Block should remain untouched with same look...

The original poster did not mean to dig out a strip in the middle.
But a line divides the two parts

I see that, but what did you do with geometry : create 2 separate blocks, or perform double CLIPIT on invisible boundaries with separational polyline, so that single block parts can move whereever you want...

[ribarm]

So, I did something similar... Here is *.lsp and *.gif...

Code - Auto/Visual Lisp: [Select]

1. (defun c:split-block ( / *error* LM:ssboundingbox process-box box obj sel spc cmd ss sb j e el b1 b2 bound1 bound2 ) ;;; frm, xfrm - global variables
2.  
3.     (vl-load-com)
4.  
5.     (defun *error* ( m )
6.         (while (= 8 (logand 8 (getvar 'undoctl)))
7.             (if command-s
8.                 (command-s "_.undo" "_e")
9.                 (vl-cmdf "_.undo" "_e")
10.             )
11.         )
12.         (if xfrm
13.             (setvar 'xclipframe 0)
14.         )
15.         (if frm
16.             (setvar 'frame 0)
17.         )
18.         (if cmd
19.             (setvar 'cmdecho cmd)
20.         )
21.         (prompt "\nUpon finish moving part of block that was separated consider returning back : xfrm variable to (setvar 'xclipframe xfrm) and frm variable to (setvar 'frame frm)...")
22.         (if m
23.             (prompt m)
24.         )
25.         (princ)
26.     )
27.  
28.     ;; Selection Set Bounding Box  -  Lee Mac
29.     ;; Returns a list of the lower-left and upper-right WCS coordinates of a
30.     ;; rectangular frame bounding all objects in a supplied selection set.
31.     ;; sel - [sel] Selection set for which to return bounding box
32.  
33.     (defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
34.         (repeat (setq idx (sslength sel))
35.             (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
36.             (if (and (vlax-method-applicable-p obj 'getboundingbox)
37.                      (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
38.                 )
39.                 (setq ls1 (mapcar 'min (vlax-safearray->list llp) (cond (ls1) ((vlax-safearray->list llp))))
40.                       ls2 (mapcar 'max (vlax-safearray->list urp) (cond (ls2) ((vlax-safearray->list urp))))
41.                 )
42.             )
43.         )
44.         (if (and ls1 ls2) (list ls1 ls2))
45.     )
46.  
47.     (defun process-box nil
48.         (if (and (setq sel (ssget "_A" (list (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))
49.                  (setq box (LM:ssboundingbox sel))
50.             )
51.             (progn
52.                 (setq spc
53.                     (vlax-get-property (vla-get-activedocument (vlax-get-acad-object))
54.                         (if (= 1 (getvar 'cvport))
55.                             'paperspace
56.                             'modelspace
57.                         )
58.                     )
59.                 )
60.                 (if (equal 0.0 (apply '- (mapcar 'caddr box)) 1e-6)
61.                     (progn
62.                         (setq obj
63.                             (vlax-invoke spc 'addlightweightpolyline
64.                                 (apply 'append
65.                                     (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) ((eval y) box)) x))
66.                                        '(
67.                                             (caar   cadar)
68.                                             (caadr  cadar)
69.                                             (caadr cadadr)
70.                                             (caar  cadadr)
71.                                         )
72.                                     )
73.                                 )
74.                             )
75.                         )
76.                         (vla-put-closed obj :vlax-true)
77.                         (vla-put-elevation obj (caddar box))
78.                     )
79.                     (apply 'vlax-invoke
80.                         (vl-list* spc 'addbox
81.                             (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
82.                             (apply 'mapcar (cons '- (reverse box)))
83.                         )
84.                     )
85.                 )
86.                 box
87.             )
88.         )
89.     )
90.  
91.     (setq cmd (getvar 'cmdecho))
92.     (setvar 'cmdecho 0)
93.     (setq xfrm (getvar 'xclipframe))
94.     (setvar 'xclipframe 0)
95.     (setq frm (getvar 'frame))
96.     (setvar 'frame 0)
97.     (while (= 8 (logand 8 (getvar 'undoctl)))
98.         (vl-cmdf "_.undo" "_e")
99.     )
100.     (vl-cmdf "_.undo" "_be")
101.     (setq box (process-box))
102.     (setq el (entlast))
103.     (prompt "\nPick division LINE, LWPOLYLINE, POLYLINE, SPLINE, ELLIPTIC ARC, ARC, or any open curve that passes desired block that is to be separated...")
104.     (setq ss (ssget "_+.:E:S:L" '((0 . "*LINE,ELLIPSE,ARC"))))
105.     (prompt "\nNow select block, hatch and bounding curve that is to be separated through converting to temp block...")
106.     (setq sb (ssget "_:L" '((0 . "INSERT,HATCH,*LINE,ELLIPSE,ARC,CIRCLE"))))
107.     (setq j 0)
108.     (while (and (setq j (1+ j)) (tblsearch "BLOCK" (strcat "X-" (cond ( (< 0 j 10) (strcat "00" (itoa j)) ) ( (< 9 j 100) (strcat "0" (itoa j)) ) ( t (itoa j) ) )))))
109.     (if command-s
110.         (command-s "_.BLOCK" (strcat "X-" (cond ( (< 0 j 10) (strcat "00" (itoa j)) ) ( (< 9 j 100) (strcat "0" (itoa j)) ) ( t (itoa j) ) )) "_non" (list 0.0 0.0 0.0) sb "")
111.         (vl-cmdf "_.BLOCK" (strcat "X-" (cond ( (< 0 j 10) (strcat "00" (itoa j)) ) ( (< 9 j 100) (strcat "0" (itoa j)) ) ( t (itoa j) ) )) "_non" (list 0.0 0.0 0.0) sb "")
112.     )
113.     (if command-s
114.         (command-s "_.INSERT" (strcat "X-" (cond ( (< 0 j 10) (strcat "00" (itoa j)) ) ( (< 9 j 100) (strcat "0" (itoa j)) ) ( t (itoa j) ) )) "_non" (list 0.0 0.0 0.0) 1.0 1.0 0.0)
115.         (vl-cmdf "_.INSERT" (strcat "X-" (cond ( (< 0 j 10) (strcat "00" (itoa j)) ) ( (< 9 j 100) (strcat "0" (itoa j)) ) ( t (itoa j) ) )) "_non" (list 0.0 0.0 0.0) 1.0 1.0 0.0)
116.     )
117.     (setq b1 (entlast))
118.     (setq b2 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object b1))))
119.     (setq e (ssname ss 0))
120.     (vl-cmdf "_.lengthen" "_de" 5.0 "_non" (trans (vlax-curve-getpointatparam e (+ (vlax-curve-getstartparam e) 0.1)) 0 1))
121.     (while (< 0 (getvar 'cmdactive))
122.         (vl-cmdf "")
123.     )
124.     (vl-cmdf "_.lengthen" "_de" 5.0 "_non" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.1)) 0 1))
125.     (while (< 0 (getvar 'cmdactive))
126.         (vl-cmdf "")
127.     )
128.     (if (and b1 (not (vlax-erased-p b1)))
129.         (entdel b1)
130.     )
131.     (if (and b2 (not (vlax-erased-p b2)))
132.         (entdel b2)
133.     )
134.     (vl-cmdf "_.-boundary" (mapcar '+ (list 0.1 0.1) (car box)))
135.     (while (< 0 (getvar 'cmdactive))
136.         (vl-cmdf "")
137.     )
138.     (setq bound1 (entlast))
139.     (vl-cmdf "_.-boundary" (mapcar '+ (list -0.1 -0.1) (cadr box)))
140.     (while (< 0 (getvar 'cmdactive))
141.         (vl-cmdf "")
142.     )
143.     (setq bound2 (entlast))
144.     (if (and b1 (vlax-erased-p b1))
145.         (entdel b1)
146.     )
147.     (if (and b2 (vlax-erased-p b2))
148.         (entdel b2)
149.     )
150.     (vl-cmdf "_.xclip" b1 "" "_n" "_s" bound1)
151.     (vl-cmdf "_.xclip" b2 "" "_n" "_s" bound2)
152.     (if (and bound1 (not (vlax-erased-p bound1)))
153.         (entdel bound1)
154.     )
155.     (if (and bound2 (not (vlax-erased-p bound2)))
156.         (entdel bound2)
157.     )
158.     (if (and el (not (vlax-erased-p el)))
159.         (entdel el)
160.     )
161.     (vl-cmdf "_.lengthen" "_de" -5.0 "_non" (trans (vlax-curve-getpointatparam e (+ (vlax-curve-getstartparam e) 0.1)) 0 1))
162.     (while (< 0 (getvar 'cmdactive))
163.         (vl-cmdf "")
164.     )
165.     (vl-cmdf "_.lengthen" "_de" -5.0 "_non" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.1)) 0 1))
166.     (while (< 0 (getvar 'cmdactive))
167.         (vl-cmdf "")
168.     )
169.     (setvar 'xclipframe 0)
170.     (vl-cmdf "_.move")
171.     (while (< 0 (getvar 'cmdactive))
172.         (vl-cmdf "\\")
173.     )
174.     (*error* nil)
175. )