Topic: Help with DoubleOffset lisp - LeeMac Code

[PM]

Hi. I am using LeeMac code for Double offset . I want an update to this code.
I need to select all lines in layer "ROOF-AXIS" and double offset them (0.08m of each side) and the put the offset lines in layer "ROOF"

Code - Auto/Visual Lisp: [Select]

1.   (command "_layer" "_m" "ROOF" "_c" "90" "" "")
2.  

Code - Auto/Visual Lisp: [Select]

1. (defun c:DOff2 nil (c:DoubleOffset))
2.  
3. (defun c:DoubleOffset ( / *error* _StartUndo _EndUndo DoubleOffset doc exitflag layer mpoint obj object of point sel symbol value )
4.  
5.   (defun *error* ( msg )    
6.     (and doc (_EndUndo doc))
7.     (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
8.         (princ (strcat "\n** Error: " msg " **")))
9.     (princ)
10.   )
11.  
12.   (defun _StartUndo ( doc ) (vla-StartUndoMark doc))
13.  
14.   (defun _EndUndo   ( doc ) (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndomark doc)))
15.  
16.   (defun DoubleOffset ( object offset layer )
17.     (mapcar
18.       (function
19.         (lambda ( o )
20.           (if
21.             (and
22.               (not
23.                 (vl-catch-all-error-p
24.                   (setq o
25.                     (vl-catch-all-apply
26.                       (function vlax-invoke) (list object 'Offset o)
27.                     )
28.                   )
29.                 )
30.               )
31.               layer
32.             )
33.             (mapcar
34.               (function
35.                 (lambda ( o )
36.                   (vla-put-layer o (getvar 'CLAYER))
37.                 )
38.               )
39.               o
40.             )
41.           )
42.         )
43.       )
44.       (list offset (- offset))
45.     )
46.   )
47.  
48.   (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
49.  
50.   (mapcar
51.     '(lambda ( symbol value ) (or (boundp symbol) (set symbol value)))
52.     '(*dOff:Erase *dOff:Layer) '("No" "Source")
53.   )
54.  
55.   (if
56.     (progn
57.       (while
58.         (progn
59.           (princ
60.             (strcat
61.               "\nCurrent Settings: Erase source="
62.               *dOff:Erase
63.               "  Layer="
64.               *dOff:Layer
65.               "  OFFSETGAPTYPE="
66.               (itoa (getvar 'OFFSETGAPTYPE))
67.             )
68.           )
69.           (initget 6 "Through Erase Layer")
70.           (setq of
71.             (getdist
72.               (strcat "\nSpecify Offset Distance [Through/Erase/Layer] <"
73.                 (if (minusp (getvar 'OFFSETDIST)) "Through"  (rtos (getvar 'OFFSETDIST))) "> : "
74.               )
75.             )
76.           )
77.           (cond
78.             (
79.               (null of) (not (setq of (getvar 'OFFSETDIST)))
80.             )
81.             (
82.               (eq "Through" of) (setq of (setvar 'OFFSETDIST -1)) nil
83.             )
84.             (
85.               (eq "Erase" of) (initget "Yes No")
86.  
87.               (setq *dOff:Erase
88.                 (cond
89.                   (
90.                     (getkword
91.                       (strcat "\nErase source object after offsetting? [Yes/No] <" *doff:Erase "> : ")
92.                     )
93.                   )
94.                   ( *dOff:Erase )
95.                 )
96.               )
97.             )
98.             (
99.               (eq "Layer" of) (initget "Current Source")
100.  
101.               (setq *dOff:Layer
102.                 (cond
103.                   (
104.                     (getkword
105.                       (strcat "\nEnter layer option for offset objects [Current/Source] <" *dOff:Layer "> : ")
106.                     )
107.                   )
108.                   ( *dOff:Layer )
109.                 )
110.               )
111.             )
112.             ( of (setvar 'OFFSETDIST of) nil )
113.           )
114.         )
115.       )
116.       of
117.     )
118.     (while
119.       (progn
120.         (or ExitFlag
121.           (progn (initget "Exit")
122.             (setq sel (entsel "\nSelect object to offset or [Exit] <Exit> : "))
123.           )
124.         )
125.        
126.         (cond
127.           (
128.             (or ExitFlag (null sel) (eq sel "Exit")) nil
129.           )
130.           ( (vl-consp sel)
131.  
132.             (_EndUndo doc) (_StartUndo doc)
133.  
134.             (if (and (wcmatch (cdr (assoc 0 (entget (car sel)))) "ARC,CIRCLE,ELLIPSE,SPLINE,LWPOLYLINE,XLINE,LINE")
135.                      (setq obj (vlax-ename->vla-object (car sel))))
136.  
137.               (if (minusp of)
138.                 (if
139.                   (progn (initget "Exit Multiple")
140.                     (and
141.                       (setq point (getpoint "\nSpecify through point or [Exit/Multiple] <Exit> : "))
142.                       (not (eq "Exit" point))
143.                     )
144.                   )
145.                   (if (eq "Multiple" point)
146.                     (while
147.                       (progn (initget "Exit")
148.                         (setq mpoint (getpoint "\nSpecify through point or [Exit] <next object> : "))
149.  
150.                         (cond
151.                           (
152.                             (eq "Exit" mpoint)
153.  
154.                             (if (eq "Yes" *dOff:Erase) (vla-delete obj))
155.  
156.                             (not (setq ExitFlag t))
157.                           )
158.                           (
159.                             (null mpoint)
160.  
161.                             (if (eq "Yes" *dOff:Erase) (vla-delete obj))
162.  
163.                             nil
164.                           )
165.                           (
166.                             (listp mpoint)
167.                            
168.                             (DoubleOffset obj
169.                               (distance (trans mpoint 1 0)
170.                                 (vlax-curve-getClosestPointto (car sel) (trans mpoint 1 0) t)
171.                               )
172.                               (eq "Current" *dOff:Layer)
173.                             )
174.                            t
175.                           )
176.                         )
177.                       )
178.                     )
179.                     (progn
180.                       (DoubleOffset obj
181.                         (distance (trans point 1 0)
182.                           (vlax-curve-getClosestPointto (car sel) (trans point 1 0) t)
183.                         )
184.                         (eq "Current" *dOff:Layer)
185.                       )
186.                       (if (eq "Yes" *dOff:Erase) (vla-delete obj))
187.                      t
188.                     )
189.                   )
190.                   (setq ExitFlag t)
191.                 )
192.                 (progn
193.                   (DoubleOffset obj of (eq "Current" *dOff:Layer))
194.  
195.                   (if (eq "Yes" *dOff:Erase) (vla-delete obj))
196.                 )
197.               )
198.               (princ "\n** Cannot Offset that Object **")
199.             )
200.            t
201.           )
202.         )
203.       )
204.     )
205.   )  
206.   (_EndUndo doc) (princ)
207. )  
208.  
209. (vl-load-com)
210.  (princ)
211.  
212.  

Thanks

[Tharwat]

Here you go.

Code - Auto/Visual Lisp: [Select]

1. (defun c:Test ( / sel int ent )
2.   ;; Tharwat - Date : 10.Apr.2021       ;;
3.   (and (or (tblsearch "LAYER" "ROOF")
4.          (alert "Layer name < ROOF >  was not found in this drawing to continue!")
5.          )
6.      (princ "\nSelect lines on layer < ROOF-AXIS > to offset on two sides 0.08 m : ")
7.      (setq int -1 sel (ssget "_:L" '((0 . "LINE")(8 . "ROOF-AXIS"))))
8.      (while (setq int (1+ int) ent (ssname sel int))
9.        (foreach off '(0.08 -0.08)
10.          (vla-put-layer (car (vlax-invoke (vlax-ename->vla-object ent) 'offset off)) "ROOF")
11.          )
12.        )
13.      )
14. (princ)
15. ) (vl-load-com)
16.  

[PM]

HI Tharwat

I try to change your code to automatic select this lines by is not work !!!

Code - Auto/Visual Lisp: [Select]

1.     (defun c:Test ( / sel int ent )
2.       ;; Tharwat - Date : 10.Apr.2021       ;;
3.       (and (or (tblsearch "LAYER" "ROOF")
4.              (alert "Layer name < ROOF >  was not found in this drawing to continue!")
5.              )
6.          ;(princ "\nSelect lines on layer < ROOF-AXIS > to offset on two sides 0.08 m : ")
7.          (ssget "_x" '((0 . "*LINE") (8 . "ROOF-AXIS")))  ; < ----- add this line
8.          (setq int -1 sel (ssget "_:L" '((0 . "LINE")(8 . "ROOF-AXIS"))))
9.          (while (setq int (1+ int) ent (ssname sel int))
10.            (foreach off '(0.08 -0.08)
11.              (vla-put-layer (car (vlax-invoke (vlax-ename->vla-object ent) 'offset off)) "ROOF")
12.              )
13.            )
14.          )
15.     (princ)
16.     ) (vl-load-com)
17.      
18.  
19.  

[Tharwat]

Replace this part from my original posted codes and please modify your post and remove your posted codes.

Code - Auto/Visual Lisp: [Select]

1.  (setq int -1 sel (ssget "_X" '((0 . "LINE")(8 . "ROOF-AXIS"))))

Be sure to have the layer ROOF-AXIS unlocked.

[PM]

Thanks

[PM]

I want ro ask you some thing else . Is it possible after the offset to fillet 0 all this lines in ROOF layer?

[BIGAL]

It would be better to make all the joining lines to plines use pedit Join, then run the offset lisp it will auto fillet then.

[PM]

Hi Bigal. I use this code to make roof. I did a combination with Tharwat code. My results is in the attach file. I want to trim -extend the offset lines to perimetric roof polylime  and fill with ANSI31 hatch like the attach file.

[PM]

The ROOF dwg  updated in the previous post

[BIGAL]

I think the ridge tops can be filleted by using a circle approach, and checking for a intersectwith, not sure can be automated, may look at making a circle on each end of red lines. The same with eave end it will be a trim or extend. Will have a think about it.

polygon
get co-ord
(setq ss (ssget "F" co-ord '((8 . "ROOF")(0 . "LINE"))))
need to do a distanceatpoint along the polygon via  intersectwith so can sort the line order into pairs then can fillet

[PM]

can any one fix it?

[BIGAL]

Need some time made a start on it be patient.

[PM]

Thanks BIGAL

[BIGAL]

Sorry took so long had a few other tasks, it only does ridge caps at moment, there is one spot where in you sample it will not work as you have 2 ridges to close so the search polygon gets confused. So just pick the top of the red line. The same method should be able to be used on the eaves.

Code: [Select]

; fillet offset roof ridges for offset lines equal ridge capping.
; by AlanH April 2021 info@alanh.com.au

(defun AHpllst ( lstpl / x)
(command "_pline")
(while (= (getvar "cmdactive") 1 )
(repeat (setq x (length lstpl))
(command (nth (setq x (- x 1)) lstpl))
)
(command "")
)
)


(defun c:test  ( / oldsnap)
(setq oldsnap (getvar 'osmode))
(setvar 'osmode 1)
(while (setq pt (getpoint "\nPick ridge point "))
(setvar 'osmode 0)
;(setq pt2 (getpoint pt "\nPick gap in ridge lines "))
; (setq ang  (angle pt pt2))
(setq ang 0.0)
(setq pi20 (/ (* 2.0 pi) 20.0))
(setq co-ord '())
(repeat 20
(setq pt2 (polar pt (setq ang (+ pi20 ang)) 0.3))
(setq co-ord (cons pt2 co-ord))
)
(setq co-ord (cons (last  co-ord) co-ord))
(AHpllst co-ord)

(setq obj1 (vlax-ename->vla-object (entlast)))

(setq ss (ssget "F" co-ord '((0 . "LINE")(8 . "ROOF"))))

(setq lst '())
(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (- x 1))))
(setq obj2 (vlax-ename->vla-object ent))
(setq pt (vlax-invoke obj2 'intersectWith obj1 acExtendnone))
(setq dist (vlax-curve-getdistatpoint obj1 pt))
(setq lst (cons (list dist pt (cdr (assoc -1 (entget ent)))) lst))
)
(setq lst (vl-sort lst '(lambda (x y) (< (car x)(car y)))))

(vla-delete obj1)
(setvar 'filletrad 0.0)

(setq x 1)
(setvar 'osmode 512)
(setq x 1)
(repeat (- (/ (length lst) 2) 1)
(setq l1 (entget (nth 2 (nth x lst))))
( setq pt1 (mapcar '* (mapcar '+ (cdr (assoc 10 l1)) (cdr (assoc 11 l1))) '(0.5 0.5)))
(setq l2 (entget (nth 2 (nth (+ x 1) lst))))
( setq pt2 (mapcar '* (mapcar '+ (cdr (assoc 10 l2)) (cdr (assoc 11 l2))) '(0.5 0.5)))

(command "fillet" pt1 pt2  )
(setq x (+ x 2))
)
(setq l1 (entget (nth 2 (nth 0 lst))))
( setq pt1 (mapcar '* (mapcar '+ (cdr (assoc 10 l1)) (cdr (assoc 11 l1))) '(0.5 0.5)))
(setq l2 (entget (nth 2 (last lst))))
( setq pt2 (mapcar '* (mapcar '+ (cdr (assoc 10 l2)) (cdr (assoc 11 l2))) '(0.5 0.5)))
(command "fillet" pt1 pt2  )

(setvar 'osmode 1)

)
(setvar 'osmode oldsnap)
(princ)

)
(c:test)



[PM]

Hi BIGAL . Thanks for your time. I try your code but is not working as i expect. Is faster to do filet 0 . Your code create arcs in the roof and became a mess.

Thanks again

[BIGAL]

I tested on your dwg and it worked ok will look further into it. Would not have posted if not working.

I did all my testing in Bricscad and it works perfect falls over in Autocad so understand not working, not sure why its happening. Will make it work.

[BIGAL]

The code works in Bricscad but not in Autocad. Which was disappointing I am now rewriting for both.

 I have found that Autocad must be able to see the points when filleting and that may be the problem. So will look at zooming or an alternative of picking the fillet points.

There is a problem in one area it will not work as you have two ridges to close to work out the line order.

Re outside eave can use extrim to auto trim overshoot, just did manual very easy, extended everything then extrim.

I have had to revert back to a version 1 to get to work in Autocad. You need to drag a start angle line. Its not perfect. I will work on it. Doing some weird things when getting the line order.

The fillet problem is to do with the pick point needs to be closer to the fillet point, say 20% instead of mid pt. Bricscad works even if unseen.

Code: [Select]

; fillet offset roof ridges for offset lines equal ridge capping.
; by AlanH April 2021 info@alanh.com.au

(defun AHpllst ( lstpl / x)
(command "_pline")
(while (= (getvar "cmdactive") 1 )
(repeat (setq x (length lstpl))
(command (nth (setq x (- x 1)) lstpl))
)
(command "")
)
)


(defun c:test  ( / oldsnap)
(setq oldsnap (getvar 'osmode))
(setvar 'osmode 1)
(setq pi30 (/ (* 2.0 pi) 30.0))

(while (setq pt (getpoint "\nPick ridge point Enter to exit "))

(setq pt2 (getpoint pt "\nPick internal gap in ridge lines "))
(setq ang  (angle pt pt2))
(setvar 'osmode 0)

(setq co-ord '())
(repeat 30
(setq pt2 (polar pt (setq ang (+ pi30 ang)) 0.21))
(setq co-ord (cons pt2 co-ord))
)
;(setq co-ord (cons (last  co-ord) co-ord))
(AHpllst co-ord)

(setq obj1 (vlax-ename->vla-object (entlast)))

(setq ss (ssget "F" co-ord '((0 . "LINE")(8 . "ROOF"))))

(setq lst '())
(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (- x 1))))
(setq obj2 (vlax-ename->vla-object ent))
(setq pt (vlax-invoke obj2 'intersectWith obj1 acExtendnone))
(setq dist (vlax-curve-getdistatpoint obj1 pt))
(setq lst (cons (list dist pt (cdr (assoc -1 (entget ent)))) lst))
)
(setq lst (vl-sort lst '(lambda (x y) (< (car x)(car y)))))

(vla-delete obj1)
(setvar 'filletrad 0.0)

(setq x 1)
(setvar 'osmode 512)
(setq x 1)
(repeat (- (/ (length lst) 2) 1)
(setq l1 (entget (nth 2 (nth x lst))))
( setq pt1 (mapcar '* (mapcar '+ (cdr (assoc 10 l1)) (cdr (assoc 11 l1))) '(0.5 0.5)))
(setq l2 (entget (nth 2 (nth (+ x 1) lst))))
( setq pt2 (mapcar '* (mapcar '+ (cdr (assoc 10 l2)) (cdr (assoc 11 l2))) '(0.5 0.5)))
(command "zoom" "C" pt 5.0)
;(command "fillet" pt1 pt2  )
(command "fillet" (nth 2 (nth x lst)) pt2  )
(command "zoom" "P" )
(setq x (+ x 2))
)
(setq l1 (entget (nth 2 (nth 0 lst))))
( setq pt1 (mapcar '* (mapcar '+ (cdr (assoc 10 l1)) (cdr (assoc 11 l1))) '(0.5 0.5)))
(setq l2 (entget (nth 2 (last lst))))
( setq pt2 (mapcar '* (mapcar '+ (cdr (assoc 10 l2)) (cdr (assoc 11 l2))) '(0.5 0.5)))
(command "fillet" (nth 2 (nth 0 lst)) pt2  )

(setvar 'osmode 1)

)
(setvar 'osmode oldsnap)
(princ)

)
(c:test)



For eave tested in Autocad.

Code: [Select]

; Clean up eave line for ridge capping
; By AlanH April 2021

(defun c:test2 ( / oldsnap ent obj pmin pmax mp outpt off1 obj1 obj2 ss co-ord lst intpt )
(setq oldsnap (getvar 'osmode))
(setq ent (car (entsel "\nPick eave pline ")))

(setq obj (vlax-ename->vla-object ent))
(vla-GetBoundingBox obj 'minpoint 'maxpoint)
(setq pmin (vlax-safearray->list minpoint))
(setq pmax (vlax-safearray->list maxpoint))
(setq mp (mapcar '* (mapcar '+ pmin pmax) '(0.5 0.5)))
(setq outpt (polar pmax (angle pmin pmax) 1.0))

(command "offset" 0.25 ent mp "")
(setq off1 (entlast))
(setq obj1 (vlax-ename->vla-object off1))
(setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget off1))))

(setq ss (ssget "F" co-ord '((0 . "line"))))

(setq lst '())
(repeat (setq x (sslength ss))
(setq obj2  (vlax-ename->vla-object (ssname ss (setq x (- x 1)))))
(setq intpt (vlax-invoke obj2 'intersectWith obj1 acExtendNone))
(setq lst (cons intpt lst))
)
(setq lst (cons (last lst) lst))

(command "erase" off1 "")

(command "offset" 0.25 ent outpt "")
(setq off1 (entlast))

(setvar 'osmode 512)

(command "extend" off1 "" "F")
(while (= (getvar "cmdactive") 1 )
(repeat (setq x (length lst))
(command (nth (setq x (- x 1)) lst))
)
(command "" "")
)

(command "erase" off1 "")
(if (null etrim) (load "extrim.lsp"))
(etrim ent outpt)

(setvar 'osmode oldsnap)
(princ)

) ; defun
(c:test2)

Problem spot if I decrease radius then does not work else where.

[PM]

Hi BIGAL, I find this code . I dont't know if is possoble to select all lines in roof layer and fillet them.   (i find it here https://forums.augi.com/showthread.php?44929-Looking-for-a-routine-for-Multiple-Fillet/page3&s=8db7f7c3ef67f5bb37fca77a4f69a5a7)

Code - Auto/Visual Lisp: [Select]

1. (defun c:mcha ( / *error* mid AssocOn ss i ent p1 p2 lin linn lins flins ptlst1 pt1 pt11 ptlst2 pt2 pt22 chpts chamfers )
2.   (vl-load-com)
3.  
4.   (defun *error* ( msg )
5.     (if chma (setvar 'chamfera chma))
6.     (if chmb (setvar 'chamferb chmb))
7.     (if chmm (setvar 'chammode chmm))
8.     (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
9.   )
10.  
11.   (defun mid ( p1 p2 )
12.     (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
13.   )
14.  
15.   (defun AssocOn ( SearchTerm Lst func fuzz )
16.     (car
17.       (vl-member-if
18.         (function
19.           (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
20.         )
21.         lst
22.       )
23.     )
24.   )
25.  
26.   (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
27.   (mapcar 'set '(chma chmb chmm) (mapcar 'getvar '(chamfera chamferb chammode)))
28.   (mapcar 'setvar '(chamfera chamferb chammode) '(0 0 0))
29.   (prompt "\nSelect line entities")
30.   (while (not (setq ss (ssget "_:L" '((0 . "LINE"))))))
31.   (setq i -1)
32.   (while (setq ent (ssname ss (setq i (1+ i))))
33.     (setq p1 (trans (vlax-curve-getstartpoint ent) 0 1))
34.     (setq p2 (trans (vlax-curve-getendpoint ent) 0 1))
35.     (setq lin (list p1 p2))
36.     (setq lins (cons lin lins))
37.   )
38.   (setq flins (apply 'append lins))
39.   (foreach lin lins
40.     (setq ptlst1 (vl-sort flins '(lambda ( a b ) (< (distance (car lin) a) (distance (car lin) b)))))
41.     (if (equal (cadr ptlst1) (cadr lin) 1e-8) (setq pt1 (caddr ptlst1)) (setq pt1 (cadr ptlst1)))
42.     (if (setq linn (assocon pt1 lins 'car 1e-8)) (setq pt11 (mid (car linn) (cadr linn))))
43.     (if (setq linn (assocon pt1 lins 'cadr 1e-8)) (setq pt11 (mid (car linn) (cadr linn))))
44.     (setq ptlst2 (vl-sort flins '(lambda ( a b ) (< (distance (cadr lin) a) (distance (cadr lin) b)))))
45.     (if (equal (cadr ptlst2) (car lin) 1e-8) (setq pt2 (caddr ptlst2)) (setq pt2 (cadr ptlst2)))
46.     (if (setq linn (assocon pt2 lins 'car 1e-8)) (setq pt22 (mid (car linn) (cadr linn))))
47.     (if (setq linn (assocon pt2 lins 'cadr 1e-8)) (setq pt22 (mid (car linn) (cadr linn))))
48.     (setq chpts (list pt11 (mid (car lin) (cadr lin))) chamfers (cons chpts chamfers) chpts (list pt22 (mid (car lin) (cadr lin))) chamfers (cons chpts chamfers))
49.   )
50.   (foreach chpts chamfers
51.     (command "_.chamfer" (car chpts) (cadr chpts))
52.   )
53.   (*error* nil)
54.   (princ)
55. )
56.  

\Thanks

[PM]

Hi BIGAL .I find a lisp code that creates multy boundaries. Is any way to use this code and bypass fillet.

Code - Auto/Visual Lisp: [Select]

1. ;Create closed polylines from selected objects
2. ;Stefan M. v1.01 07.03.2014
3. ;updated - v1.02 16.10.2018
4. ;updated - v1.03 27.11.2018
5. (defun c:epl ( / *error* break_object l2p ms ss i z_dir o_dir e lst segments pa dr aa ce reg ea)
6.   (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
7.   (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
8.   (vla-startundomark acDoc)
9.   (setq pa (getvar 'peditaccept)
10.         dr (getvar 'draworderctl)
11.         ce (getvar 'cmdecho)
12.         aa 0.00
13.   )
14.  
15.   (defun *error* (msg)
16.     (and
17.       msg
18.       (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
19.       (princ (strcat "\nError: " msg))
20.       )
21.     (foreach x (append segments lst) (vl-catch-all-apply 'vla-delete (list x)))
22.     (setvar 'peditaccept pa)
23.     (setvar 'draworderctl dr)
24.     (setvar 'cmdecho ce)
25.     (vla-endundomark acDoc)
26.     (princ)
27.   )
28.  
29.   (defun l2p (l) (if l (cons (list (car l) (cadr l) (caddr l)) (l2p (cdddr l)))))
30.  
31.   (defun break_object (e points / object_type start center end radius normal arc res)
32.     (if points
33.       (progn
34.         (setq points
35.           (vl-sort points
36.             (function
37.               (lambda (a b)
38.                 (<
39.                   (vlax-curve-getdistatpoint e (vlax-curve-getclosestpointto e a))
40.                   (vlax-curve-getdistatpoint e (vlax-curve-getclosestpointto e b))
41.                 )
42.               )
43.             )
44.           )
45.         )
46.         (cond
47.           ((eq (setq object_type (vla-get-ObjectName e)) "AcDbLine")
48.            (setq start (vlax-curve-getstartpoint e))
49.            (while points
50.              (if (> (distance start (car points)) 1e-5)
51.                (setq res (cons (vlax-invoke ms 'addline start (setq start (car points))) res))
52.                )
53.              (setq points (cdr points))
54.              )
55.            )
56.           (T
57.            (if
58.              (eq object_type "AcDbArc")
59.              (setq start  (vlax-curve-getStartParam e))
60.              (setq start  (vlax-curve-getparamatpoint e (car points))
61.                    points (reverse (cons (car points) (reverse (cdr points))))
62.              )
63.            )
64.            (setq   center (vla-get-Center e)
65.                    radius (vla-get-Radius e)
66.                    normal (vla-get-Normal e)
67.            )
68.            (while points
69.              (if (not (equal start (setq end (vlax-curve-getparamatpoint e (car points))) 1e-5))
70.                (progn
71.                  (setq arc (vla-AddArc ms center radius start end))
72.                  (vla-put-Normal arc normal)
73.                  (setq res (cons arc res))
74.                )
75.              )
76.              (setq points (cdr points)
77.                    start end)
78.              )
79.            )
80.          )
81.        )
82.      )
83.     res
84.   )
85.          
86.   (if
87.     (setq ss (ssget ":L" '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE"))))
88.     (progn
89.       (setq z_dir (trans '(0 0  1) 1 0 t))
90.       (repeat (setq i (sslength ss))
91.         (setq i (1- i)
92.               e (ssname ss i)
93.               o_dir (cdr (assoc 210 (entget e)))
94.               e (vlax-ename->vla-object e)
95.         )
96.         (if
97.           (equal o_dir z_dir 1e-8)
98.           (if
99.             (eq (vla-get-ObjectName e) "AcDbPolyline")
100.             (foreach x (vlax-invoke e 'Explode)
101.               (setq lst (cons x lst))
102.             )
103.             (setq lst (cons (vla-copy e) lst))
104.           )
105.         )
106.       )
107.       (if
108.         (and
109.           (setq segments
110.             (apply 'append
111.               (mapcar
112.                 (function
113.                   (lambda (e / l)
114.                     (break_object e
115.                       (progn
116.                         (foreach other (vl-remove e lst)
117.                           (foreach x (l2p (vlax-invoke e 'intersectwith other acExtendNone))
118.                              (if
119.                                (equal x (vlax-curve-getclosestpointto e x) 1e-8)
120.                                (setq l (cons x l))
121.                              )
122.                           )
123.                         )
124.                         (if
125.                           (eq (vla-get-ObjectName e) "AcDbCircle")
126.                           l
127.                           (cons (vlax-curve-getendpoint e) l)
128.                         )
129.                       )
130.                     )
131.                   )
132.                 )
133.                 lst
134.               )
135.             )
136.           )
137.           (not
138.             (vl-catch-all-error-p
139.               (setq reg
140.                (vl-catch-all-apply 'vlax-invoke (list ms 'AddRegion segments))
141.               )
142.             )
143.           )
144.         )
145.         (progn
146.           (setvar 'peditaccept 1)
147.           (setvar 'draworderctl 0)
148.           (setvar 'cmdecho 0)
149.           (foreach x reg
150.             (setq x (vlax-vla-object->ename x))
151.             (command "_explode" x)
152.             (command "_pedit" "_m" "_p" "" "_j" "" "")
153.             (if (> (vlax-curve-getArea (entlast)) aa) (setq aa (vlax-curve-getArea (setq ea (entlast)))))
154.           )
155.           (entdel ea)
156.           (setvar 'peditaccept pa)
157.           (setvar 'draworderctl dr)
158.           (setvar 'cmdecho ce)
159.         )
160.         (princ "\nValid region(s) not found")
161.       )
162.     )
163.   )
164.   (*error* nil)
165.   (princ)
166. )
167.  
168.  
169.