- Home
- /
- Architecture, Engineering & Construction
- /
- AutoCAD Forums
- /
- Visual LISP, AutoLISP and General Customization Forum
- /
- Re: alternative of _BOUNDARY in the mode of pick point
alternative of _BOUNDARY in the mode of pick point
Options
- Subscribe to RSS Feed
- Mark Topic as New
- Mark Topic as Read
- Float this Topic for Current User
- Bookmark
- Subscribe
- Mute
- Printer Friendly Page
alternative of _BOUNDARY in the mode of pick point
Advisor
5,766 Views
70 Replies
5,767 Views
70 Replies
Replies (70)
- « Previous
- Next »
Message 61 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Actually, when you think deep enough even further from previous thought, you'll realize that there may exist case when both sel. sets s1 and s2 are the same - XLINE just nearly passes through two edges that are on extent of boundary... In that situation you'll have to use still my previous version solution - only the smallest REGION of more of them obtained as common members from both sel. sets s1 and s2 is taking in consideration for deriving LWPOLYLINE or SPLINE which is then used in COPYBASE, UNDO, PASTECLIP commands... I hope this is now final version :
(defun c:bndr ( / *error* unit bbucs ssoverent process *adoc* osm pck qaf ss p bb dx dy kx ky pp ipx ipp1 ipp2 ippl1 ippl2 rec ch pl pll li1 li2 i1 c1 i2 c2 ip ipl trl s el k e i ray ipp ippl kk cadrtt ttt trx trxx tx procl xli reg ssreg s1 s2 ppl pp1 pp2 ell ti )
(vl-load-com)
(defun *error* ( m )
(if osm
(setvar 'osmode osm)
)
(if pck
(setvar 'pickbox pck)
)
(if qaf
(setvar 'qaflags qaf)
)
(vla-endundomark *adoc*)
(if m
(prompt m)
)
(princ)
)
(defun unit ( v )
(if (not (equal v '(0.0 0.0 0.0) 1e-6))
(mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
)
)
(defun ssoverent ( sp ep ent / spar epar len k dx ssx px pxx pxxx sx sxx sxxx )
(vl-load-com)
(setq spar (vlax-curve-getparamatpoint ent sp))
(setq epar (vlax-curve-getparamatpoint ent ep))
(setq len (- (vlax-curve-getdistatparam ent epar) (vlax-curve-getdistatparam ent spar)))
(setq k 0 dx (/ len 100.0) ssx (ssadd))
(repeat 99
(setq px (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (setq k (1+ k)) dx))))
(setq pxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (+ k 0.5) dx))))
(setq pxxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (- k 0.5) dx))))
(setq sx (ssget "_C" (trans px 0 1) (trans px 0 1)))
(setq sxx (ssget "_C" (trans pxx 0 1) (trans pxx 0 1)))
(setq sxxx (ssget "_C" (trans pxxx 0 1) (trans pxxx 0 1)))
(cond
( (and sx sxx sxxx)
(if (not (vl-every '(lambda ( x ) (and (ssmemb x sxx) (ssmemb x sxxx))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
( (and sx sxx (not sxxx))
(if (not (vl-every '(lambda ( x ) (ssmemb x sxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
( (and sx (not sxx) sxxx)
(if (not (vl-every '(lambda ( x ) (ssmemb x sxxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
)
(if sx
(repeat (setq ii (sslength sx))
(ssadd (ssname sx (setq ii (1- ii))) ssx)
)
)
)
ssx
)
(defun bbucs ( ss / UCS2WCSMatrix WCS2UCSMatrix n ent minpt maxpt minptlst maxptlst minptbbx minptbby minptbbz minptbb maxptbbx maxptbby maxptbbz maxptbb )
(vl-load-com)
;; Doug C. Broad, Jr.
;; can be used with vla-transformby to
;; transform objects from the UCS to the WCS
(defun UCS2WCSMatrix ()
(vlax-tmatrix
(append
(mapcar
'(lambda (vector origin)
(append (trans vector 1 0 t) (list origin))
)
(list '(1 0 0) '(0 1 0) '(0 0 1))
(trans '(0 0 0) 0 1)
)
(list '(0 0 0 1))
)
)
)
;; transform objects from the WCS to the UCS
(defun WCS2UCSMatrix ()
(vlax-tmatrix
(append
(mapcar
'(lambda (vector origin)
(append (trans vector 0 1 t) (list origin))
)
(list '(1 0 0) '(0 1 0) '(0 0 1))
(trans '(0 0 0) 1 0)
)
(list '(0 0 0 1))
)
)
)
(if ss
(progn
(repeat (setq n (sslength ss))
(setq ent (ssname ss (setq n (1- n))))
(vla-TransformBy (vlax-ename->vla-object ent) (UCS2WCSMatrix))
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
(vla-TransformBy (vlax-ename->vla-object ent) (WCS2UCSMatrix))
(setq minpt (vlax-safearray->list minpoint))
(setq maxpt (vlax-safearray->list maxpoint))
(setq minptlst (cons minpt minptlst))
(setq maxptlst (cons maxpt maxptlst))
)
(setq minptbbx (caar (vl-sort minptlst '(lambda (a b) (< (car a) (car b))))))
(setq minptbby (cadar (vl-sort minptlst '(lambda (a b) (< (cadr a) (cadr b))))))
(setq minptbbz (caddar (vl-sort minptlst '(lambda (a b) (< (caddr a) (caddr b))))))
(setq maxptbbx (caar (vl-sort maxptlst '(lambda (a b) (> (car a) (car b))))))
(setq maxptbby (cadar (vl-sort maxptlst '(lambda (a b) (> (cadr a) (cadr b))))))
(setq maxptbbz (caddar (vl-sort maxptlst '(lambda (a b) (> (caddr a) (caddr b))))))
(setq minptbb (list minptbbx minptbby minptbbz))
(setq maxptbb (list maxptbbx maxptbby maxptbbz))
)
)
(list minptbb maxptbb)
)
(defun process ( trll f / el k e sx ii entl np1 np2 d1 d2 )
(vl-load-com)
(foreach tr trll
(if (and (wcmatch (cdr (assoc 0 (entget (cadr tr)))) "ELLIPSE,CIRCLE") (equal (vlax-curve-getstartpoint (cadr tr)) (vlax-curve-getendpoint (cadr tr)) 1e-6))
(progn
(setq np1 (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
(setq np2 (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
(setq d1 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np1)) pl)))
(setq d2 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np2)) pl)))
(if (< d1 d2)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
(ssadd (ssname (ssget "_C" np1 np1) 0) s)
)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
(ssadd (ssname (ssget "_C" np2 np2) 0) s)
)
)
)
(progn
(setq el (entlast))
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
(> (sslength (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1))) 1)
)
(progn
(if f
(setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (cadr tr) (ssoverent (vlax-curve-getstartpoint (cadr tr)) (car tr) (cadr tr)))))))
)
(if entl
(foreach ent entl
(entdel ent)
)
)
(if (vlax-erased-p el)
(setq el (entlast))
)
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(cond
( (and (not (eq el (entlast))) (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr))))
(if (not (eq (cadr tr) (entlast)))
(entdel (cadr tr))
)
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
(command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(if (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
(ssadd (entlast) s)
(if (not (eq el (entlast)))
(progn
(entdel (entlast))
(if (not (vlax-erased-p (cadr tr)))
(ssadd (cadr tr) s)
(progn
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(repeat (setq ii (sslength sx))
(if
(or
(and
(equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
)
(and
(equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
)
)
(ssadd (ssname sx ii) s)
)
)
)
)
)
(if (not (vlax-erased-p (cadr tr)))
(ssadd (cadr tr) s)
(progn
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(repeat (setq ii (sslength sx))
(if
(or
(and
(equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
)
(and
(equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
)
)
(ssadd (ssname sx ii) s)
)
)
)
)
)
)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
( (and (not (eq el (entlast))) (not (and (vlax-curve-getparamatpoint (cadr tr) (car tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr)))))
(entdel (cadr tr))
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(setq e (car (vl-remove-if-not '(lambda ( x ) (vlax-curve-getparamatpoint x (caddr tr))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx))))))
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
(command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(ssadd e s)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
( t
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(if (and (not (eq el (entlast))) (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
(ssadd (entlast) s)
(if (not (eq el (entlast)))
(progn
(entdel (entlast))
(ssadd (cadr tr) s)
)
(ssadd (cadr tr) s)
)
)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
)
)
)
)
)
(vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
(setq osm (getvar 'osmode))
(setvar 'osmode 0)
(setq pck (getvar 'pickbox))
(setq qaf (getvar 'qaflags))
(prompt "\nSelect boundary curve entities...")
(setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
(while (not ss)
(prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
(setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
)
(setq sss (ssadd))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(if (wcmatch (cdr (assoc 0 (entget e))) "~*POLYLINE")
(ssadd e sss)
)
)
(setvar 'qaflags 1)
(command "_.EXPLODE" ss)
(while (< 0 (getvar 'cmdactive))
(command "")
)
(setq ss (ssget "_P"))
(if (null ss)
(setq ss (ssadd))
)
(if (/= (sslength sss) 0)
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex sss)))
(ssadd e ss)
)
)
(initget 1)
(setq p (getpoint "\nPick or specify internal point : "))
(initget "Yes No")
(setq ch (getkword "\nDoes boundary contour have narrow passage [Yes/No] <Yes> : "))
(if (null ch)
(setq ch "Yes")
)
(setq ti (car (_vl-times)))
(setvar 'pickbox 1)
(setq bb (bbucs ss))
(setq bb (subst (list (car (car bb)) (cadr (car bb)) 0.0) (car bb) bb))
(setq bb (subst (list (car (cadr bb)) (cadr (cadr bb)) 0.0) (cadr bb) bb))
(setq dx (/ (abs (- (car (cadr bb)) (car (car bb)))) 11.0))
(setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 11.0))
(setq ky 0)
(repeat 10
(setq ky (1+ ky))
(setq kx 0)
(repeat 10
(setq kx (1+ kx))
(setq pp (list (+ (car (car bb)) (* kx dx)) (+ (cadr (car bb)) (* ky dy)) 0.0))
(setq pl (cons pp pl))
)
)
(setq rec
(entmakex
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 38 (caddr (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t))))
(cons 10 (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (list (car (cadr bb)) (cadr (car bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (cadr bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (list (car (car bb)) (cadr (cadr bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 210 (trans '(0.0 0.0 1.0) 1 0 t))
)
)
)
(foreach pp pl
(setq li1 (entmakex (list '(0 . "LINE") (cons 10 (trans p 1 0)) (cons 11 (trans pp 1 0)))))
(setq li2 (entmakex (list '(0 . "LINE") (cons 10 (trans pp 1 0)) (cons 11 (vlax-curve-getclosestpointto rec (trans pp 1 0))))))
(setq ippl1 nil ippl2 nil)
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(setq ipp1 (vlax-invoke (vlax-ename->vla-object li1) 'intersectwith (vlax-ename->vla-object e) acextendnone))
(setq ippl1 (append ipp1 ippl1))
(setq ipp2 (vlax-invoke (vlax-ename->vla-object li2) 'intersectwith (vlax-ename->vla-object e) acextendnone))
(setq ippl2 (append ipp2 ippl2))
)
(if (= ch "Yes")
(if (and (or (null ippl1) (= 0 (rem (length ippl1) 6))) (not (null ippl2)))
(setq pll (cons pp pll))
)
(if (and (null ippl1) (not (null ippl2)))
(setq pll (cons pp pll))
)
)
(entdel li1)
(entdel li2)
)
(entdel rec)
;|
(foreach pp pll
(entmake (list '(0 . "POINT") (cons 10 (trans pp 1 0))))
)
|;
(repeat (setq i1 (sslength ss))
(setq c1 (ssname ss (setq i1 (1- i1))))
(ssdel c1 ss)
(repeat (setq i2 (sslength ss))
(setq c2 (ssname ss (setq i2 (1- i2))))
(setq ip nil pp nil ipx nil)
(setq ip (vlax-invoke (vlax-ename->vla-object c1) 'intersectwith (vlax-ename->vla-object c2) acextendnone))
(cond
( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
(setq pp (vlax-curve-getstartpoint c1))
)
( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getendpoint c2) 1e-6)
(setq pp (vlax-curve-getstartpoint c1))
)
( (equal (vlax-curve-getendpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
(setq pp (vlax-curve-getendpoint c1))
)
( (equal (vlax-curve-getendpoint c1) (vlax-curve-getendpoint c2) 1e-6)
(setq pp (vlax-curve-getendpoint c1))
)
)
(if ip
(repeat (/ (length ip) 3)
(setq ipx (cons (list (car ip) (cadr ip) (caddr ip)) ipx))
(setq ip (cdddr ip))
)
)
(if (and pp (not (vl-member-if '(lambda ( x ) (equal x pp 1e-6)) ipx)))
(progn
(setq ipp (append (apply 'append ipx) ipp))
(setq ipp (append pp ipp))
)
(setq ipp (append (apply 'append ipx) ipp))
)
)
(if ipp
(repeat (/ (length ipp) 3)
(setq ipl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ipl))
(setq ipp (cdddr ipp))
)
)
(setq ipl (vl-sort ipl '(lambda ( a b ) (< (vlax-curve-getparamatpoint c1 a) (vlax-curve-getparamatpoint c1 b)))))
(mapcar
'(lambda ( a b / loop k v ray ipp ippl )
(setq loop t k -1)
(while (and loop (setq pp (nth (setq k (1+ k)) pll)))
(setq ippl nil)
(setq v (unit (mapcar '- (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (trans pp 1 0))))
(setq ray (entmakex (list '(0 . "RAY") '(100 . "AcDbEntity") '(100 . "AcDbRay") (cons 10 (trans pp 1 0)) (cons 11 v))))
(setq ipp (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c1) acextendnone))
(repeat (setq i2 (sslength ss))
(setq c2 (ssname ss (setq i2 (1- i2))))
(setq ipp (append (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c2) acextendnone) ipp))
)
(if ipp
(repeat (/ (length ipp) 3)
(setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
(setq ipp (cdddr ipp))
)
)
(if (equal (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (car (setq ippl (vl-sort ippl '(lambda ( a b ) (< (vlax-curve-getparamatpoint ray a) (vlax-curve-getparamatpoint ray b)))))) 1e-6)
(if (not (vl-position (list a c1 b) trl))
(setq trl (cons (list a c1 b) trl) loop nil)
)
)
(entdel ray)
)
)
ipl
(cdr ipl)
)
(setq ipl nil)
(ssadd c1 ss)
)
(setq trl (vl-sort trl '(lambda ( a b ) (< (vlax-curve-getparamatpoint (cadr a) (car a)) (vlax-curve-getparamatpoint (cadr b) (car b))))))
(setq k -1)
(while (setq tr (nth (setq k (1+ k)) trl))
(setq kk -1)
(if (not (or (eq (last tr) t) (eq (last tr) nil)))
(foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
(setq kk (1+ kk))
(if (and (= kk 0) (> (length (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)) 1))
(progn
(setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
(setq trx (cons (list (car tr) (cadr tr) (caddr tr) nil) trx))
)
)
(if (> kk 0)
(progn
(setq cadrtt (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))))
(setq ttt (list (car tt) cadrtt (caddr tt)))
(if (not (equal tt tr 1e-6))
(progn
(setq trl
(subst
(repeat kk
(setq ttt (reverse (cons t (reverse ttt))))
)
tt
trl
)
)
(setq trx (cons ttt trx))
)
)
)
)
)
)
)
(setq trx (reverse trx))
(foreach tt trx
(setq trl (vl-remove tt trl))
)
(setq s (ssadd))
(process trl nil)
(foreach txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)
(setq trxx (member txnil trx) procl nil)
(while (and (setq tx (car trxx)) (not (equal tx (nth (1+ (vl-position txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx))) (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)) 1e-6)))
(setq procl (cons tx procl))
(setq trxx (cdr trxx))
)
(process (reverse procl) t)
)
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
(setq ss (ssget "_C" (trans (vlax-curve-getstartpoint ent) 0 1) (trans (vlax-curve-getstartpoint ent) 0 1)))
(repeat (setq i (sslength ss))
(ssadd (ssname ss (setq i (1- i))) s)
)
(setq ss (ssget "_C" (trans (vlax-curve-getendpoint ent) 0 1) (trans (vlax-curve-getendpoint ent) 0 1)))
(repeat (setq i (sslength ss))
(ssadd (ssname ss (setq i (1- i))) s)
)
)
(setq el (entlast))
(command "_.REGION" s "")
(setq xli (entmakex (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 (trans p 1 0)) (cons 11 (trans '(1.0 0.0 0.0) 1 0 t)))))
(setq ssreg (ssadd))
(while (setq el (entnext el))
(ssadd el ssreg)
)
(repeat (setq i (sslength ssreg))
(setq reg (ssname ssreg (setq i (1- i))))
(setq ip (vlax-invoke (vlax-ename->vla-object xli) 'intersectwith (vlax-ename->vla-object reg) acextendnone))
(setq ipl (append ip ipl))
)
(repeat (/ (length ipl) 3)
(setq ppl (cons (list (car ipl) (cadr ipl) (caddr ipl)) ppl))
(setq ipl (cdddr ipl))
)
(setq pp1 (car (vl-sort ppl '(lambda ( a b ) (< (distance (trans p 1 0) a) (distance (trans p 1 0) b))))))
(setq ppl (vl-remove-if '(lambda ( x ) (equal (unit (mapcar '- x (trans p 1 0))) (unit (mapcar '- pp1 (trans p 1 0))) 1e-6)) ppl))
(setq pp2 (car (vl-sort ppl '(lambda ( a b ) (< (distance (trans p 1 0) a) (distance (trans p 1 0) b))))))
(setq s1 (ssget "_C" (trans pp1 0 1) (trans pp1 0 1) '((0 . "REGION"))))
(setq s2 (ssget "_C" (trans pp2 0 1) (trans pp2 0 1) '((0 . "REGION"))))
(entdel xli)
(foreach reg (vl-remove-if 'listp (mapcar 'cadr (ssnamex s1)))
(if (ssmemb reg s2)
(setq ell (cons reg ell))
)
)
(setq e (car (vl-sort ell '(lambda ( a b ) (< (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))
(command "_.CONVTOSURFACE" e "")
(setq el (entlast))
(command "_.OFFSETEDGE" "_non" pp "_D" "0.0")
(while (< 0 (getvar 'cmdactive))
(command "")
)
(entdel el)
(setq e (entlast))
(command "_.COPYBASE" "_non" '(0.0 0.0 0.0) e "")
(command "_.UNDO" "_B")
(command "_.PASTECLIP" "_non" '(0.0 0.0 0.0))
(sssetfirst nil (ssadd (entlast)))
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
(*error* nil)
)Regards, HTH, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 62 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Sorry it should be :
(command "_.OFFSETEDGE" "_non" (trans pp1 0 1) "_D" "0.0")
(defun c:bndr ( / *error* unit bbucs ssoverent process *adoc* osm pck qaf ss p bb dx dy kx ky pp ipx ipp1 ipp2 ippl1 ippl2 rec ch pl pll li1 li2 i1 c1 i2 c2 ip ipl trl s el k e i ray ipp ippl kk cadrtt ttt trx trxx tx procl xli reg ssreg s1 s2 ppl pp1 pp2 ell ti )
(vl-load-com)
(defun *error* ( m )
(if osm
(setvar 'osmode osm)
)
(if pck
(setvar 'pickbox pck)
)
(if qaf
(setvar 'qaflags qaf)
)
(vla-endundomark *adoc*)
(if m
(prompt m)
)
(princ)
)
(defun unit ( v )
(if (not (equal v '(0.0 0.0 0.0) 1e-6))
(mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
)
)
(defun ssoverent ( sp ep ent / spar epar len k dx ssx px pxx pxxx sx sxx sxxx )
(vl-load-com)
(setq spar (vlax-curve-getparamatpoint ent sp))
(setq epar (vlax-curve-getparamatpoint ent ep))
(setq len (- (vlax-curve-getdistatparam ent epar) (vlax-curve-getdistatparam ent spar)))
(setq k 0 dx (/ len 100.0) ssx (ssadd))
(repeat 99
(setq px (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (setq k (1+ k)) dx))))
(setq pxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (+ k 0.5) dx))))
(setq pxxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (- k 0.5) dx))))
(setq sx (ssget "_C" (trans px 0 1) (trans px 0 1)))
(setq sxx (ssget "_C" (trans pxx 0 1) (trans pxx 0 1)))
(setq sxxx (ssget "_C" (trans pxxx 0 1) (trans pxxx 0 1)))
(cond
( (and sx sxx sxxx)
(if (not (vl-every '(lambda ( x ) (and (ssmemb x sxx) (ssmemb x sxxx))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
( (and sx sxx (not sxxx))
(if (not (vl-every '(lambda ( x ) (ssmemb x sxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
( (and sx (not sxx) sxxx)
(if (not (vl-every '(lambda ( x ) (ssmemb x sxxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
)
(if sx
(repeat (setq ii (sslength sx))
(ssadd (ssname sx (setq ii (1- ii))) ssx)
)
)
)
ssx
)
(defun bbucs ( ss / UCS2WCSMatrix WCS2UCSMatrix n ent minpt maxpt minptlst maxptlst minptbbx minptbby minptbbz minptbb maxptbbx maxptbby maxptbbz maxptbb )
(vl-load-com)
;; Doug C. Broad, Jr.
;; can be used with vla-transformby to
;; transform objects from the UCS to the WCS
(defun UCS2WCSMatrix ()
(vlax-tmatrix
(append
(mapcar
'(lambda (vector origin)
(append (trans vector 1 0 t) (list origin))
)
(list '(1 0 0) '(0 1 0) '(0 0 1))
(trans '(0 0 0) 0 1)
)
(list '(0 0 0 1))
)
)
)
;; transform objects from the WCS to the UCS
(defun WCS2UCSMatrix ()
(vlax-tmatrix
(append
(mapcar
'(lambda (vector origin)
(append (trans vector 0 1 t) (list origin))
)
(list '(1 0 0) '(0 1 0) '(0 0 1))
(trans '(0 0 0) 1 0)
)
(list '(0 0 0 1))
)
)
)
(if ss
(progn
(repeat (setq n (sslength ss))
(setq ent (ssname ss (setq n (1- n))))
(vla-TransformBy (vlax-ename->vla-object ent) (UCS2WCSMatrix))
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
(vla-TransformBy (vlax-ename->vla-object ent) (WCS2UCSMatrix))
(setq minpt (vlax-safearray->list minpoint))
(setq maxpt (vlax-safearray->list maxpoint))
(setq minptlst (cons minpt minptlst))
(setq maxptlst (cons maxpt maxptlst))
)
(setq minptbbx (caar (vl-sort minptlst '(lambda (a b) (< (car a) (car b))))))
(setq minptbby (cadar (vl-sort minptlst '(lambda (a b) (< (cadr a) (cadr b))))))
(setq minptbbz (caddar (vl-sort minptlst '(lambda (a b) (< (caddr a) (caddr b))))))
(setq maxptbbx (caar (vl-sort maxptlst '(lambda (a b) (> (car a) (car b))))))
(setq maxptbby (cadar (vl-sort maxptlst '(lambda (a b) (> (cadr a) (cadr b))))))
(setq maxptbbz (caddar (vl-sort maxptlst '(lambda (a b) (> (caddr a) (caddr b))))))
(setq minptbb (list minptbbx minptbby minptbbz))
(setq maxptbb (list maxptbbx maxptbby maxptbbz))
)
)
(list minptbb maxptbb)
)
(defun process ( trll f / el k e sx ii entl np1 np2 d1 d2 )
(vl-load-com)
(foreach tr trll
(if (and (wcmatch (cdr (assoc 0 (entget (cadr tr)))) "ELLIPSE,CIRCLE") (equal (vlax-curve-getstartpoint (cadr tr)) (vlax-curve-getendpoint (cadr tr)) 1e-6))
(progn
(setq np1 (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
(setq np2 (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
(setq d1 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np1)) pl)))
(setq d2 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np2)) pl)))
(if (< d1 d2)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
(ssadd (ssname (ssget "_C" np1 np1) 0) s)
)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
(ssadd (ssname (ssget "_C" np2 np2) 0) s)
)
)
)
(progn
(setq el (entlast))
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
(> (sslength (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1))) 1)
)
(progn
(if f
(setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (cadr tr) (ssoverent (vlax-curve-getstartpoint (cadr tr)) (car tr) (cadr tr)))))))
)
(if entl
(foreach ent entl
(entdel ent)
)
)
(if (vlax-erased-p el)
(setq el (entlast))
)
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(cond
( (and (not (eq el (entlast))) (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr))))
(if (not (eq (cadr tr) (entlast)))
(entdel (cadr tr))
)
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
(command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(if (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
(ssadd (entlast) s)
(if (not (eq el (entlast)))
(progn
(entdel (entlast))
(if (not (vlax-erased-p (cadr tr)))
(ssadd (cadr tr) s)
(progn
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(repeat (setq ii (sslength sx))
(if
(or
(and
(equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
)
(and
(equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
)
)
(ssadd (ssname sx ii) s)
)
)
)
)
)
(if (not (vlax-erased-p (cadr tr)))
(ssadd (cadr tr) s)
(progn
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(repeat (setq ii (sslength sx))
(if
(or
(and
(equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
)
(and
(equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
)
)
(ssadd (ssname sx ii) s)
)
)
)
)
)
)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
( (and (not (eq el (entlast))) (not (and (vlax-curve-getparamatpoint (cadr tr) (car tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr)))))
(entdel (cadr tr))
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(setq e (car (vl-remove-if-not '(lambda ( x ) (vlax-curve-getparamatpoint x (caddr tr))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx))))))
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
(command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(ssadd e s)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
( t
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(if (and (not (eq el (entlast))) (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
(ssadd (entlast) s)
(if (not (eq el (entlast)))
(progn
(entdel (entlast))
(ssadd (cadr tr) s)
)
(ssadd (cadr tr) s)
)
)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
)
)
)
)
)
(vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
(setq osm (getvar 'osmode))
(setvar 'osmode 0)
(setq pck (getvar 'pickbox))
(setq qaf (getvar 'qaflags))
(prompt "\nSelect boundary curve entities...")
(setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
(while (not ss)
(prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
(setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
)
(setq sss (ssadd))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(if (wcmatch (cdr (assoc 0 (entget e))) "~*POLYLINE")
(ssadd e sss)
)
)
(setvar 'qaflags 1)
(command "_.EXPLODE" ss)
(while (< 0 (getvar 'cmdactive))
(command "")
)
(setq ss (ssget "_P"))
(if (null ss)
(setq ss (ssadd))
)
(if (/= (sslength sss) 0)
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex sss)))
(ssadd e ss)
)
)
(initget 1)
(setq p (getpoint "\nPick or specify internal point : "))
(initget "Yes No")
(setq ch (getkword "\nDoes boundary contour have narrow passage [Yes/No] <Yes> : "))
(if (null ch)
(setq ch "Yes")
)
(setq ti (car (_vl-times)))
(setvar 'pickbox 1)
(setq bb (bbucs ss))
(setq bb (subst (list (car (car bb)) (cadr (car bb)) 0.0) (car bb) bb))
(setq bb (subst (list (car (cadr bb)) (cadr (cadr bb)) 0.0) (cadr bb) bb))
(setq dx (/ (abs (- (car (cadr bb)) (car (car bb)))) 11.0))
(setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 11.0))
(setq ky 0)
(repeat 10
(setq ky (1+ ky))
(setq kx 0)
(repeat 10
(setq kx (1+ kx))
(setq pp (list (+ (car (car bb)) (* kx dx)) (+ (cadr (car bb)) (* ky dy)) 0.0))
(setq pl (cons pp pl))
)
)
(setq rec
(entmakex
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 38 (caddr (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t))))
(cons 10 (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (list (car (cadr bb)) (cadr (car bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (cadr bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (list (car (car bb)) (cadr (cadr bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 210 (trans '(0.0 0.0 1.0) 1 0 t))
)
)
)
(foreach pp pl
(setq li1 (entmakex (list '(0 . "LINE") (cons 10 (trans p 1 0)) (cons 11 (trans pp 1 0)))))
(setq li2 (entmakex (list '(0 . "LINE") (cons 10 (trans pp 1 0)) (cons 11 (vlax-curve-getclosestpointto rec (trans pp 1 0))))))
(setq ippl1 nil ippl2 nil)
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(setq ipp1 (vlax-invoke (vlax-ename->vla-object li1) 'intersectwith (vlax-ename->vla-object e) acextendnone))
(setq ippl1 (append ipp1 ippl1))
(setq ipp2 (vlax-invoke (vlax-ename->vla-object li2) 'intersectwith (vlax-ename->vla-object e) acextendnone))
(setq ippl2 (append ipp2 ippl2))
)
(if (= ch "Yes")
(if (and (or (null ippl1) (= 0 (rem (length ippl1) 6))) (not (null ippl2)))
(setq pll (cons pp pll))
)
(if (and (null ippl1) (not (null ippl2)))
(setq pll (cons pp pll))
)
)
(entdel li1)
(entdel li2)
)
(entdel rec)
;|
(foreach pp pll
(entmake (list '(0 . "POINT") (cons 10 (trans pp 1 0))))
)
|;
(repeat (setq i1 (sslength ss))
(setq c1 (ssname ss (setq i1 (1- i1))))
(ssdel c1 ss)
(repeat (setq i2 (sslength ss))
(setq c2 (ssname ss (setq i2 (1- i2))))
(setq ip nil pp nil ipx nil)
(setq ip (vlax-invoke (vlax-ename->vla-object c1) 'intersectwith (vlax-ename->vla-object c2) acextendnone))
(cond
( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
(setq pp (vlax-curve-getstartpoint c1))
)
( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getendpoint c2) 1e-6)
(setq pp (vlax-curve-getstartpoint c1))
)
( (equal (vlax-curve-getendpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
(setq pp (vlax-curve-getendpoint c1))
)
( (equal (vlax-curve-getendpoint c1) (vlax-curve-getendpoint c2) 1e-6)
(setq pp (vlax-curve-getendpoint c1))
)
)
(if ip
(repeat (/ (length ip) 3)
(setq ipx (cons (list (car ip) (cadr ip) (caddr ip)) ipx))
(setq ip (cdddr ip))
)
)
(if (and pp (not (vl-member-if '(lambda ( x ) (equal x pp 1e-6)) ipx)))
(progn
(setq ipp (append (apply 'append ipx) ipp))
(setq ipp (append pp ipp))
)
(setq ipp (append (apply 'append ipx) ipp))
)
)
(if ipp
(repeat (/ (length ipp) 3)
(setq ipl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ipl))
(setq ipp (cdddr ipp))
)
)
(setq ipl (vl-sort ipl '(lambda ( a b ) (< (vlax-curve-getparamatpoint c1 a) (vlax-curve-getparamatpoint c1 b)))))
(mapcar
'(lambda ( a b / loop k v ray ipp ippl )
(setq loop t k -1)
(while (and loop (setq pp (nth (setq k (1+ k)) pll)))
(setq ippl nil)
(setq v (unit (mapcar '- (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (trans pp 1 0))))
(setq ray (entmakex (list '(0 . "RAY") '(100 . "AcDbEntity") '(100 . "AcDbRay") (cons 10 (trans pp 1 0)) (cons 11 v))))
(setq ipp (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c1) acextendnone))
(repeat (setq i2 (sslength ss))
(setq c2 (ssname ss (setq i2 (1- i2))))
(setq ipp (append (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c2) acextendnone) ipp))
)
(if ipp
(repeat (/ (length ipp) 3)
(setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
(setq ipp (cdddr ipp))
)
)
(if (equal (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (car (setq ippl (vl-sort ippl '(lambda ( a b ) (< (vlax-curve-getparamatpoint ray a) (vlax-curve-getparamatpoint ray b)))))) 1e-6)
(if (not (vl-position (list a c1 b) trl))
(setq trl (cons (list a c1 b) trl) loop nil)
)
)
(entdel ray)
)
)
ipl
(cdr ipl)
)
(setq ipl nil)
(ssadd c1 ss)
)
(setq trl (vl-sort trl '(lambda ( a b ) (< (vlax-curve-getparamatpoint (cadr a) (car a)) (vlax-curve-getparamatpoint (cadr b) (car b))))))
(setq k -1)
(while (setq tr (nth (setq k (1+ k)) trl))
(setq kk -1)
(if (not (or (eq (last tr) t) (eq (last tr) nil)))
(foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
(setq kk (1+ kk))
(if (and (= kk 0) (> (length (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)) 1))
(progn
(setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
(setq trx (cons (list (car tr) (cadr tr) (caddr tr) nil) trx))
)
)
(if (> kk 0)
(progn
(setq cadrtt (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))))
(setq ttt (list (car tt) cadrtt (caddr tt)))
(if (not (equal tt tr 1e-6))
(progn
(setq trl
(subst
(repeat kk
(setq ttt (reverse (cons t (reverse ttt))))
)
tt
trl
)
)
(setq trx (cons ttt trx))
)
)
)
)
)
)
)
(setq trx (reverse trx))
(foreach tt trx
(setq trl (vl-remove tt trl))
)
(setq s (ssadd))
(process trl nil)
(foreach txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)
(setq trxx (member txnil trx) procl nil)
(while (and (setq tx (car trxx)) (not (equal tx (nth (1+ (vl-position txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx))) (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)) 1e-6)))
(setq procl (cons tx procl))
(setq trxx (cdr trxx))
)
(process (reverse procl) t)
)
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
(setq ss (ssget "_C" (trans (vlax-curve-getstartpoint ent) 0 1) (trans (vlax-curve-getstartpoint ent) 0 1)))
(repeat (setq i (sslength ss))
(ssadd (ssname ss (setq i (1- i))) s)
)
(setq ss (ssget "_C" (trans (vlax-curve-getendpoint ent) 0 1) (trans (vlax-curve-getendpoint ent) 0 1)))
(repeat (setq i (sslength ss))
(ssadd (ssname ss (setq i (1- i))) s)
)
)
(setq el (entlast))
(command "_.REGION" s "")
(setq xli (entmakex (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 (trans p 1 0)) (cons 11 (trans '(1.0 0.0 0.0) 1 0 t)))))
(setq ssreg (ssadd))
(while (setq el (entnext el))
(ssadd el ssreg)
)
(repeat (setq i (sslength ssreg))
(setq reg (ssname ssreg (setq i (1- i))))
(setq ip (vlax-invoke (vlax-ename->vla-object xli) 'intersectwith (vlax-ename->vla-object reg) acextendnone))
(setq ipl (append ip ipl))
)
(repeat (/ (length ipl) 3)
(setq ppl (cons (list (car ipl) (cadr ipl) (caddr ipl)) ppl))
(setq ipl (cdddr ipl))
)
(setq pp1 (car (vl-sort ppl '(lambda ( a b ) (< (distance (trans p 1 0) a) (distance (trans p 1 0) b))))))
(setq ppl (vl-remove-if '(lambda ( x ) (equal (unit (mapcar '- x (trans p 1 0))) (unit (mapcar '- pp1 (trans p 1 0))) 1e-6)) ppl))
(setq pp2 (car (vl-sort ppl '(lambda ( a b ) (< (distance (trans p 1 0) a) (distance (trans p 1 0) b))))))
(setq s1 (ssget "_C" (trans pp1 0 1) (trans pp1 0 1) '((0 . "REGION"))))
(setq s2 (ssget "_C" (trans pp2 0 1) (trans pp2 0 1) '((0 . "REGION"))))
(entdel xli)
(foreach reg (vl-remove-if 'listp (mapcar 'cadr (ssnamex s1)))
(if (ssmemb reg s2)
(setq ell (cons reg ell))
)
)
(setq e (car (vl-sort ell '(lambda ( a b ) (< (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))
(command "_.CONVTOSURFACE" e "")
(setq el (entlast))
(command "_.OFFSETEDGE" "_non" (trans pp1 0 1) "_D" "0.0")
(while (< 0 (getvar 'cmdactive))
(command "")
)
(entdel el)
(setq e (entlast))
(command "_.COPYBASE" "_non" '(0.0 0.0 0.0) e "")
(command "_.UNDO" "_B")
(command "_.PASTECLIP" "_non" '(0.0 0.0 0.0))
(sssetfirst nil (ssadd (entlast)))
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
(*error* nil)
)M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 63 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Since command ISOLATEOBJECTS was introduced in A2011 before OFFSETEDGE command in A2012, I've decided to implement it in code, as it was coded for A2012+ versions... Of course if you have A2012- you should remove last derivation of LWPOLYLINE or SPLINE entity from REGION at the end of the code and remove this intervention with command ISOLATEOBJECTS (A2011-)... This intervention is needed for using if you have ISLANDS and as LISP wasn't written to operate with them I implemented line :
(command "_.ISOLATEOBJECTS" ss "")
just after selection was made to make sure you don't need to put ISLANDS on separate LAYER or something like that, but make sure you don't select ISLANDS... That's it, hope you can find it useful in some situations... Regards, M.R.
(defun c:bndr ( / *error* unit bbucs ssoverent process *adoc* osm pck qaf ss p bb dx dy kx ky pp ipx ipp1 ipp2 ippl1 ippl2 rec ch pl pll li1 li2 i1 c1 i2 c2 ip ipl trl s el k e i ray ipp ippl kk cadrtt ttt trx trxx tx procl xli reg ssreg s1 s2 ppl pp1 pp2 ell ti )
(vl-load-com)
(defun *error* ( m )
(if osm
(setvar 'osmode osm)
)
(if pck
(setvar 'pickbox pck)
)
(if qaf
(setvar 'qaflags qaf)
)
(vla-endundomark *adoc*)
(if m
(prompt m)
)
(princ)
)
(defun unit ( v )
(if (not (equal v '(0.0 0.0 0.0) 1e-6))
(mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
)
)
(defun ssoverent ( sp ep ent / spar epar len k dx ssx px pxx pxxx sx sxx sxxx )
(vl-load-com)
(setq spar (vlax-curve-getparamatpoint ent sp))
(setq epar (vlax-curve-getparamatpoint ent ep))
(setq len (- (vlax-curve-getdistatparam ent epar) (vlax-curve-getdistatparam ent spar)))
(setq k 0 dx (/ len 100.0) ssx (ssadd))
(repeat 99
(setq px (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (setq k (1+ k)) dx))))
(setq pxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (+ k 0.5) dx))))
(setq pxxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (- k 0.5) dx))))
(setq sx (ssget "_C" (trans px 0 1) (trans px 0 1)))
(setq sxx (ssget "_C" (trans pxx 0 1) (trans pxx 0 1)))
(setq sxxx (ssget "_C" (trans pxxx 0 1) (trans pxxx 0 1)))
(cond
( (and sx sxx sxxx)
(if (not (vl-every '(lambda ( x ) (and (ssmemb x sxx) (ssmemb x sxxx))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
( (and sx sxx (not sxxx))
(if (not (vl-every '(lambda ( x ) (ssmemb x sxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
( (and sx (not sxx) sxxx)
(if (not (vl-every '(lambda ( x ) (ssmemb x sxxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
(setq sx nil)
)
)
)
(if sx
(repeat (setq ii (sslength sx))
(ssadd (ssname sx (setq ii (1- ii))) ssx)
)
)
)
ssx
)
(defun bbucs ( ss / UCS2WCSMatrix WCS2UCSMatrix n ent minpt maxpt minptlst maxptlst minptbbx minptbby minptbbz minptbb maxptbbx maxptbby maxptbbz maxptbb )
(vl-load-com)
;; Doug C. Broad, Jr.
;; can be used with vla-transformby to
;; transform objects from the UCS to the WCS
(defun UCS2WCSMatrix ()
(vlax-tmatrix
(append
(mapcar
'(lambda (vector origin)
(append (trans vector 1 0 t) (list origin))
)
(list '(1 0 0) '(0 1 0) '(0 0 1))
(trans '(0 0 0) 0 1)
)
(list '(0 0 0 1))
)
)
)
;; transform objects from the WCS to the UCS
(defun WCS2UCSMatrix ()
(vlax-tmatrix
(append
(mapcar
'(lambda (vector origin)
(append (trans vector 0 1 t) (list origin))
)
(list '(1 0 0) '(0 1 0) '(0 0 1))
(trans '(0 0 0) 1 0)
)
(list '(0 0 0 1))
)
)
)
(if ss
(progn
(repeat (setq n (sslength ss))
(setq ent (ssname ss (setq n (1- n))))
(vla-TransformBy (vlax-ename->vla-object ent) (UCS2WCSMatrix))
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
(vla-TransformBy (vlax-ename->vla-object ent) (WCS2UCSMatrix))
(setq minpt (vlax-safearray->list minpoint))
(setq maxpt (vlax-safearray->list maxpoint))
(setq minptlst (cons minpt minptlst))
(setq maxptlst (cons maxpt maxptlst))
)
(setq minptbbx (caar (vl-sort minptlst '(lambda (a b) (< (car a) (car b))))))
(setq minptbby (cadar (vl-sort minptlst '(lambda (a b) (< (cadr a) (cadr b))))))
(setq minptbbz (caddar (vl-sort minptlst '(lambda (a b) (< (caddr a) (caddr b))))))
(setq maxptbbx (caar (vl-sort maxptlst '(lambda (a b) (> (car a) (car b))))))
(setq maxptbby (cadar (vl-sort maxptlst '(lambda (a b) (> (cadr a) (cadr b))))))
(setq maxptbbz (caddar (vl-sort maxptlst '(lambda (a b) (> (caddr a) (caddr b))))))
(setq minptbb (list minptbbx minptbby minptbbz))
(setq maxptbb (list maxptbbx maxptbby maxptbbz))
)
)
(list minptbb maxptbb)
)
(defun process ( trll f / el k e sx ii entl np1 np2 d1 d2 )
(vl-load-com)
(foreach tr trll
(if (and (wcmatch (cdr (assoc 0 (entget (cadr tr)))) "ELLIPSE,CIRCLE") (equal (vlax-curve-getstartpoint (cadr tr)) (vlax-curve-getendpoint (cadr tr)) 1e-6))
(progn
(setq np1 (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
(setq np2 (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
(setq d1 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np1)) pl)))
(setq d2 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np2)) pl)))
(if (< d1 d2)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
(ssadd (ssname (ssget "_C" np1 np1) 0) s)
)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
(ssadd (ssname (ssget "_C" np2 np2) 0) s)
)
)
)
(progn
(setq el (entlast))
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
(> (sslength (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1))) 1)
)
(progn
(if f
(setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (cadr tr) (ssoverent (vlax-curve-getstartpoint (cadr tr)) (car tr) (cadr tr)))))))
)
(if entl
(foreach ent entl
(entdel ent)
)
)
(if (vlax-erased-p el)
(setq el (entlast))
)
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(cond
( (and (not (eq el (entlast))) (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr))))
(if (not (eq (cadr tr) (entlast)))
(entdel (cadr tr))
)
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
(command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(if (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
(ssadd (entlast) s)
(if (not (eq el (entlast)))
(progn
(entdel (entlast))
(if (not (vlax-erased-p (cadr tr)))
(ssadd (cadr tr) s)
(progn
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(repeat (setq ii (sslength sx))
(if
(or
(and
(equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
)
(and
(equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
)
)
(ssadd (ssname sx ii) s)
)
)
)
)
)
(if (not (vlax-erased-p (cadr tr)))
(ssadd (cadr tr) s)
(progn
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(repeat (setq ii (sslength sx))
(if
(or
(and
(equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
)
(and
(equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
(equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
)
)
(ssadd (ssname sx ii) s)
)
)
)
)
)
)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
( (and (not (eq el (entlast))) (not (and (vlax-curve-getparamatpoint (cadr tr) (car tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr)))))
(entdel (cadr tr))
(setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
(setq e (car (vl-remove-if-not '(lambda ( x ) (vlax-curve-getparamatpoint x (caddr tr))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx))))))
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
(command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(ssadd e s)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
( t
(if
(and
(not (equal (car tr) (caddr tr) 1e-6))
(not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
(> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
)
(progn
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
(while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
(command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
(while (< 0 (getvar 'cmdactive))
(command "")
)
)
)
)
(if (and (not (eq el (entlast))) (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
(ssadd (entlast) s)
(if (not (eq el (entlast)))
(progn
(entdel (entlast))
(ssadd (cadr tr) s)
)
(ssadd (cadr tr) s)
)
)
(if entl
(foreach ent entl
(if (vlax-erased-p ent)
(entdel ent)
)
)
)
)
)
)
)
)
)
(vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
(setq osm (getvar 'osmode))
(setvar 'osmode 0)
(setq pck (getvar 'pickbox))
(setq qaf (getvar 'qaflags))
(prompt "\nSelect boundary curve entities...")
(setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
(while (not ss)
(prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
(setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
)
(command "_.ISOLATEOBJECTS" ss "")
(setq sss (ssadd))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(if (wcmatch (cdr (assoc 0 (entget e))) "~*POLYLINE")
(ssadd e sss)
)
)
(setvar 'qaflags 1)
(command "_.EXPLODE" ss)
(while (< 0 (getvar 'cmdactive))
(command "")
)
(setq ss (ssget "_P"))
(if (null ss)
(setq ss (ssadd))
)
(if (/= (sslength sss) 0)
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex sss)))
(ssadd e ss)
)
)
(initget 1)
(setq p (getpoint "\nPick or specify internal point : "))
(initget "Yes No")
(setq ch (getkword "\nDoes boundary contour have narrow passage [Yes/No] <Yes> : "))
(if (null ch)
(setq ch "Yes")
)
(setq ti (car (_vl-times)))
(setvar 'pickbox 1)
(setq bb (bbucs ss))
(setq bb (subst (list (car (car bb)) (cadr (car bb)) 0.0) (car bb) bb))
(setq bb (subst (list (car (cadr bb)) (cadr (cadr bb)) 0.0) (cadr bb) bb))
(setq dx (/ (abs (- (car (cadr bb)) (car (car bb)))) 11.0))
(setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 11.0))
(setq ky 0)
(repeat 10
(setq ky (1+ ky))
(setq kx 0)
(repeat 10
(setq kx (1+ kx))
(setq pp (list (+ (car (car bb)) (* kx dx)) (+ (cadr (car bb)) (* ky dy)) 0.0))
(setq pl (cons pp pl))
)
)
(setq rec
(entmakex
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 38 (caddr (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t))))
(cons 10 (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (list (car (cadr bb)) (cadr (car bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (cadr bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 10 (trans (list (car (car bb)) (cadr (cadr bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
(cons 210 (trans '(0.0 0.0 1.0) 1 0 t))
)
)
)
(foreach pp pl
(setq li1 (entmakex (list '(0 . "LINE") (cons 10 (trans p 1 0)) (cons 11 (trans pp 1 0)))))
(setq li2 (entmakex (list '(0 . "LINE") (cons 10 (trans pp 1 0)) (cons 11 (vlax-curve-getclosestpointto rec (trans pp 1 0))))))
(setq ippl1 nil ippl2 nil)
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(setq ipp1 (vlax-invoke (vlax-ename->vla-object li1) 'intersectwith (vlax-ename->vla-object e) acextendnone))
(setq ippl1 (append ipp1 ippl1))
(setq ipp2 (vlax-invoke (vlax-ename->vla-object li2) 'intersectwith (vlax-ename->vla-object e) acextendnone))
(setq ippl2 (append ipp2 ippl2))
)
(if (= ch "Yes")
(if (and (or (null ippl1) (= 0 (rem (length ippl1) 6))) (not (null ippl2)))
(setq pll (cons pp pll))
)
(if (and (null ippl1) (not (null ippl2)))
(setq pll (cons pp pll))
)
)
(entdel li1)
(entdel li2)
)
(entdel rec)
;|
(foreach pp pll
(entmake (list '(0 . "POINT") (cons 10 (trans pp 1 0))))
)
|;
(repeat (setq i1 (sslength ss))
(setq c1 (ssname ss (setq i1 (1- i1))))
(ssdel c1 ss)
(repeat (setq i2 (sslength ss))
(setq c2 (ssname ss (setq i2 (1- i2))))
(setq ip nil pp nil ipx nil)
(setq ip (vlax-invoke (vlax-ename->vla-object c1) 'intersectwith (vlax-ename->vla-object c2) acextendnone))
(cond
( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
(setq pp (vlax-curve-getstartpoint c1))
)
( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getendpoint c2) 1e-6)
(setq pp (vlax-curve-getstartpoint c1))
)
( (equal (vlax-curve-getendpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
(setq pp (vlax-curve-getendpoint c1))
)
( (equal (vlax-curve-getendpoint c1) (vlax-curve-getendpoint c2) 1e-6)
(setq pp (vlax-curve-getendpoint c1))
)
)
(if ip
(repeat (/ (length ip) 3)
(setq ipx (cons (list (car ip) (cadr ip) (caddr ip)) ipx))
(setq ip (cdddr ip))
)
)
(if (and pp (not (vl-member-if '(lambda ( x ) (equal x pp 1e-6)) ipx)))
(progn
(setq ipp (append (apply 'append ipx) ipp))
(setq ipp (append pp ipp))
)
(setq ipp (append (apply 'append ipx) ipp))
)
)
(if ipp
(repeat (/ (length ipp) 3)
(setq ipl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ipl))
(setq ipp (cdddr ipp))
)
)
(setq ipl (vl-sort ipl '(lambda ( a b ) (< (vlax-curve-getparamatpoint c1 a) (vlax-curve-getparamatpoint c1 b)))))
(mapcar
'(lambda ( a b / loop k v ray ipp ippl )
(setq loop t k -1)
(while (and loop (setq pp (nth (setq k (1+ k)) pll)))
(setq ippl nil)
(setq v (unit (mapcar '- (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (trans pp 1 0))))
(setq ray (entmakex (list '(0 . "RAY") '(100 . "AcDbEntity") '(100 . "AcDbRay") (cons 10 (trans pp 1 0)) (cons 11 v))))
(setq ipp (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c1) acextendnone))
(repeat (setq i2 (sslength ss))
(setq c2 (ssname ss (setq i2 (1- i2))))
(setq ipp (append (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c2) acextendnone) ipp))
)
(if ipp
(repeat (/ (length ipp) 3)
(setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
(setq ipp (cdddr ipp))
)
)
(if (equal (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (car (setq ippl (vl-sort ippl '(lambda ( a b ) (< (vlax-curve-getparamatpoint ray a) (vlax-curve-getparamatpoint ray b)))))) 1e-6)
(if (not (vl-position (list a c1 b) trl))
(setq trl (cons (list a c1 b) trl) loop nil)
)
)
(entdel ray)
)
)
ipl
(cdr ipl)
)
(setq ipl nil)
(ssadd c1 ss)
)
(setq trl (vl-sort trl '(lambda ( a b ) (< (vlax-curve-getparamatpoint (cadr a) (car a)) (vlax-curve-getparamatpoint (cadr b) (car b))))))
(setq k -1)
(while (setq tr (nth (setq k (1+ k)) trl))
(setq kk -1)
(if (not (or (eq (last tr) t) (eq (last tr) nil)))
(foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
(setq kk (1+ kk))
(if (and (= kk 0) (> (length (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)) 1))
(progn
(setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
(setq trx (cons (list (car tr) (cadr tr) (caddr tr) nil) trx))
)
)
(if (> kk 0)
(progn
(setq cadrtt (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))))
(setq ttt (list (car tt) cadrtt (caddr tt)))
(if (not (equal tt tr 1e-6))
(progn
(setq trl
(subst
(repeat kk
(setq ttt (reverse (cons t (reverse ttt))))
)
tt
trl
)
)
(setq trx (cons ttt trx))
)
)
)
)
)
)
)
(setq trx (reverse trx))
(foreach tt trx
(setq trl (vl-remove tt trl))
)
(setq s (ssadd))
(process trl nil)
(foreach txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)
(setq trxx (member txnil trx) procl nil)
(while (and (setq tx (car trxx)) (not (equal tx (nth (1+ (vl-position txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx))) (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)) 1e-6)))
(setq procl (cons tx procl))
(setq trxx (cdr trxx))
)
(process (reverse procl) t)
)
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
(setq ss (ssget "_C" (trans (vlax-curve-getstartpoint ent) 0 1) (trans (vlax-curve-getstartpoint ent) 0 1)))
(repeat (setq i (sslength ss))
(ssadd (ssname ss (setq i (1- i))) s)
)
(setq ss (ssget "_C" (trans (vlax-curve-getendpoint ent) 0 1) (trans (vlax-curve-getendpoint ent) 0 1)))
(repeat (setq i (sslength ss))
(ssadd (ssname ss (setq i (1- i))) s)
)
)
(setq el (entlast))
(command "_.REGION" s "")
(setq xli (entmakex (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 (trans p 1 0)) (cons 11 (trans '(1.0 0.0 0.0) 1 0 t)))))
(setq ssreg (ssadd))
(while (setq el (entnext el))
(ssadd el ssreg)
)
(repeat (setq i (sslength ssreg))
(setq reg (ssname ssreg (setq i (1- i))))
(setq ip (vlax-invoke (vlax-ename->vla-object xli) 'intersectwith (vlax-ename->vla-object reg) acextendnone))
(setq ipl (append ip ipl))
)
(repeat (/ (length ipl) 3)
(setq ppl (cons (list (car ipl) (cadr ipl) (caddr ipl)) ppl))
(setq ipl (cdddr ipl))
)
(setq pp1 (car (vl-sort ppl '(lambda ( a b ) (< (distance (trans p 1 0) a) (distance (trans p 1 0) b))))))
(setq ppl (vl-remove-if '(lambda ( x ) (equal (unit (mapcar '- x (trans p 1 0))) (unit (mapcar '- pp1 (trans p 1 0))) 1e-6)) ppl))
(setq pp2 (car (vl-sort ppl '(lambda ( a b ) (< (distance (trans p 1 0) a) (distance (trans p 1 0) b))))))
(setq s1 (ssget "_C" (trans pp1 0 1) (trans pp1 0 1) '((0 . "REGION"))))
(setq s2 (ssget "_C" (trans pp2 0 1) (trans pp2 0 1) '((0 . "REGION"))))
(entdel xli)
(foreach reg (vl-remove-if 'listp (mapcar 'cadr (ssnamex s1)))
(if (ssmemb reg s2)
(setq ell (cons reg ell))
)
)
(setq e (car (vl-sort ell '(lambda ( a b ) (< (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))
(command "_.CONVTOSURFACE" e "")
(setq el (entlast))
(command "_.OFFSETEDGE" "_non" (trans pp1 0 1) "_D" "0.0")
(while (< 0 (getvar 'cmdactive))
(command "")
)
(entdel el)
(setq e (entlast))
(command "_.COPYBASE" "_non" '(0.0 0.0 0.0) e "")
(command "_.UNDO" "_B")
(command "_.PASTECLIP" "_non" '(0.0 0.0 0.0))
(sssetfirst nil (ssadd (entlast)))
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
(*error* nil)
)
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 64 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Marko, It is possible that smaller areas affected in these cases. Which I do not think the islands - they are not isolated.
-- Alexander, private person, pacifist, english only with translator 🙂 --
Object-modeling _ odclass-odedit.com _ Help
Message 65 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Marko,
In cases of "invalid" it is visible that temporal REGION's are created. Almost all possible. Though, obviously not all necessary. And often duplicated. Probably, it is necessary to create all REGION's, but only minimum possible.
Creation is temporal all possible REGION's - possible option of what I called earlier "to create model of all lines".
For example, there is already old FlashPolygons. Works very quickly - that is there is a hope that it is possible to repeat success.
When all polygons are found, to find in what pick point, already simply.
And the task of creation of all possible polygons is very valuable directly too.
-- Alexander, private person, pacifist, english only with translator 🙂 --
Object-modeling _ odclass-odedit.com _ Help
Message 66 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Perhaps, it is useful:
http://codepen.io/timo22345/pen/LpEbWB?editors=101
http://www.me.berkeley.edu/~mcmains/pubs/DAC05OffsetPolygon.pdf
https://en.wikipedia.org/wiki/DE-9IM
-- Alexander, private person, pacifist, english only with translator 🙂 --
Object-modeling _ odclass-odedit.com _ Help
Message 67 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Alex, computer can't think... If you can describe what is exactly failing with your testings, what are expectations and so on, maybe someone willing to reply can make it possible to solve the problem... I am testing the code I posted and I had no unsatisfactory results... Maybe with some special case it bugs, but I wrote on what was known to my knowledge and available implementations of ALISP functions... Previous link is pointing to program that's written for baying and it's protected vlx routine... To my knowledge I am unable to use it and even if I could I don't want to spoil someone's business or plans with written author rights... If you find my offered code have lacks then the best is to try to fix them with your own skills... I thought you can appreciate my willing to help you in request you were searching... I know I maybe don't have more advanced skills, but like I said the code is written to be a simple alternative to BOUNDARY command and it certainly is doing similar operation not as fast as it could be, but as good as mentioned command is currently doing... If not for learning then it was good task to find some inspiration and maybe someone can build on it further more... Thank you for pointing additional links that may be useful for tackling the task from other point of view but I think that even now "bndr.lsp" has also its advantages over pointed FlashPolygon and TotalBoundary plugins, for which I don't want to give wrong opinions... Certainly they all serve for what they were written and if the task is simple then all of this would be free... Simply the task you asked for solving is taking time and dedication so the best is to try to use what you have and build on knowledge or stuff you think is useful in for that reason I wish you good luck in programming and soon and good result of your work we'll all appreciate...
Marko R.
Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 68 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Marco, is sorry for me that I can't be the real assistant. Thank you for your efforts and desire to help!
It is possible that this problem isn't solved on LISP or very difficult decides.
It is possible that it is really difficult task.
It is possible that for the solution of this task it is necessary to solve two other complex problems - creations of "model" of all lines and very fast processing of huge number of lines.
I am not a programmer. I can only look for solutions, wait, test and give unsuccessful advice.
-- Alexander, private person, pacifist, english only with translator 🙂 --
Object-modeling _ odclass-odedit.com _ Help
Message 69 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Just got the first version for testing:
The solution is possible!
-- Alexander, private person, pacifist, english only with translator 🙂 --
Object-modeling _ odclass-odedit.com _ Help
Message 70 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Yes, SuperBoundary is easy to use:
TotalPurge (www.totalpurge.com) - is a perfect optimization solution for drawings in AutoCAD environment
Message 71 of 71
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
It would be helpful if region objects had some kind of coordinate data to work with.
Does anyone know how to decipher all that dxf 1 code gibberish?
John F. Uhden
- « Previous
- Next »