Community

alternative of _BOUNDARY in the mode of pick point

alternative of _BOUNDARY in the mode of pick point

АлексЮстасу
Advisor Advisor
5,783 Views
70 Replies
Message 1 of 71

alternative of _BOUNDARY in the mode of pick point

АлексЮстасу
Advisor
Advisor
‎12-02-2015 06:03 PM

I search an alternative to the command _BOUNDARY in the mode of pick point, for finding out minimum contours from intersecting elements (polylines, 3D polylines, lines, circles, ellipses, arcs,  splines, multilines, regions):
1. not depending on the sizes of elements on the screen;
2. not depending on that, whether all possible elements of border are visible on the screen;
3. not thinking very long or infinitely;
4. not simplifying the found contours.

I found one variant - program BNDR only, but she does not develop, and actually inaccessible.
I made video. At first it is shown how BNDR works, and then _BOUNDARY.

https://youtu.be/aG01-R1nrQE - for model example.
https://youtu.be/iBE86OtIOog - for real data.

I hope that is other alternatives of BOUNDARY, that can be developed.


-- Alexander, private person, pacifist, english only with translator 🙂 --

Object-modeling _ odclass-odedit.com _ Help

0 Likes
Like
Report
5,784 Views
70 Replies
Replies (70)
Message 21 of 71

АлексЮстасу
Advisor
Advisor
in reply to marko_ribar
‎06-07-2016 05:36 PM

Marco,

You have already done a great job!
But while BNDR is unstable. Examples attached.

Why it is necessary pre-select objects? The pick point mode, in my opinion, is not necessary?bndr_m5_1.png bndr_m5_2.png

 

bndr_m5_3.pngbndr_m5_4.pngbndr_m5_5.png


-- Alexander, private person, pacifist, english only with translator 🙂 --

Object-modeling _ odclass-odedit.com _ Help

boundary_01.dwg
boundary_0.dwg
0 Likes
Like
Report
Message 22 of 71

marko_ribar
Advisor
Advisor
in reply to АлексЮстасу
‎06-08-2016 03:16 AM

Alex this is for just simple cases, so your first pictures have islands and for this situations it will fail like you shown... For the cases of 2 DWGs you posted, I've discovered where the lacks in the code were... So retest your DWGs with this modification :

 

(defun c:bndr ( / *error* unit bbucs *adoc* pea pck ss p bb dx dy kx ky pp ipp1 ipp2 ippl1 ippl2 rec pl pll li1 li2 i1 c1 i2 c2 ip ipl trl s el sx ii cx k e i ray ipp ippl )

  (vl-load-com)

  (defun *error* ( m )
    (if pea
      (setvar 'peditaccept pea)
    )
    (if pck
      (setvar 'pickbox pck)
    )
    (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 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)
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (setq pea (getvar 'peditaccept))
  (setvar 'peditaccept 1)
  (setq pck (getvar 'pickbox))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,CIRCLE,ELLIPSE"))))
  (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,CIRCLE,ELLIPSE"))))
  )
  (initget 1)
  (setq p (getpoint "\nPick or specify internal point : "))
  (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)))) 10.0))
  (setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 10.0))
  (setq ky 0)
  (repeat 9
    (setq ky (1+ ky))
    (setq kx 0)
    (repeat 9
      (setq kx (1+ kx))
      (setq pp (list (+ (car (car bb)) (* kx dx)) (+ (cadr (car bb)) (* ky dy)) 0.0))
      (if (and (/= kx 1) (/= ky 1) (/= kx 9) (/= ky 9))
        (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 (and (or (null ippl1) (= 0 (rem (length ippl1) 6))) (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 (vlax-invoke (vlax-ename->vla-object c1) 'intersectwith (vlax-ename->vla-object c2) acextendnone))
      (if (null ip)
        (cond
          ( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
            (setq ip (vlax-curve-getstartpoint c1))
          )
          ( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getendpoint c2) 1e-6)
            (setq ip (vlax-curve-getstartpoint c1))
          )
          ( (equal (vlax-curve-getendpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
            (setq ip (vlax-curve-getendpoint c1))
          )
          ( (equal (vlax-curve-getendpoint c1) (vlax-curve-getendpoint c2) 1e-6)
            (setq ip (vlax-curve-getendpoint c1))
          )
        )
      )
      (setq ipp (append ip 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 / ray ipp ippl v )
        (foreach pp pll
          (setq ippl nil)
          (setq v (unit (mapcar '- (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 a) (vlax-curve-getparamatpoint 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 a) (vlax-curve-getparamatpoint 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))
            )
          )
          (entdel ray)
        )
      )
      ipl
      (cdr ipl)
    )
    (setq ipl nil)
    (ssadd c1 ss)
  )
  (foreach tr trl
    (repeat (1- (length (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)))
      (setq trl (subst (list (car tr) (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tr)))) (caddr tr) t) tr trl))
    )
  )
  (foreach tr trl
    (if (eq (last tr) t)
      (entdel (cadr tr))
    )
  )
  (setq s (ssadd))
  (foreach tr (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (if
      (not
        (or
          (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6)
          (equal (vlax-curve-getendpoint (cadr tr)) (car tr) 1e-6)
        )
      )
      (progn
        (setq cx (entget (cadr tr)))
        (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001)))))) 0 1) "")
        (setq k 0)
        (while (equal cx (entget (cadr tr)) 1e-6)
          (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.1)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001))))))) 0 1) "")
        )
      )
    )
    (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
          (not
            (or
              (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (entlast)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (entlast)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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
          (not
            (or
              (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget e))
            (if (< (vlax-curve-getparamatpoint e (car tr)) (vlax-curve-getparamatpoint e (caddr tr)))
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.1) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.01) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.001) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.01)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.001)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (not
            (or
              (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (cadr tr)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (cadr tr)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
          )
        )
      )
    )
  )
  (foreach tr (vl-remove-if-not '(lambda ( x ) (eq (last x) t)) trl)
    (entdel (cadr tr))
    (setq el (entlast))
    (if
      (not
        (or
          (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6)
          (equal (vlax-curve-getendpoint (cadr tr)) (car tr) 1e-6)
        )
      )
      (progn
        (setq cx (entget (cadr tr)))
        (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001)))))) 0 1) "")
        (setq k 0)
        (while (equal cx (entget (cadr tr)) 1e-6)
          (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.1)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001))))))) 0 1) "")
        )
      )
    )
    (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
          (not
            (or
              (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (entlast)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (entlast)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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
          (not
            (or
              (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget e))
            (if (< (vlax-curve-getparamatpoint e (car tr)) (vlax-curve-getparamatpoint e (caddr tr)))
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.1) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.01) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.001) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.01)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.001)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (not
            (or
              (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (cadr tr)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (cadr tr)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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 (vl-some '(lambda ( x ) (if (wcmatch (cdr (assoc 0 (entget x))) "SPLINE,ELLIPSE") (setq e x))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
    (command "_.JOIN" e s "")
    (progn
      (command "_.PEDIT" "_M" s "" "_J" "_J" "_E" 0.0)
      (while (< 0 (getvar 'cmdactive))
        (command "")
      )
    )
  )
  (setq ray (entmakex (list '(0 . "RAY") '(100 . "AcDbEntity") '(100 . "AcDbRay") (cons 10 (trans p 1 0)) (cons 11 (getvar 'ucsxdir)))))
  (setq ss (ssget "_A"))
  (ssdel ray ss)
  (repeat (setq i (sslength ss))
    (setq e (ssname ss (setq i (1- i))))
    (setq ipp (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object e) acextendnone))
    (setq ippl (append ipp ippl))
  )
  (setq ipp nil)
  (repeat (/ (length ippl) 3)
    (setq ipp (cons (list (car ippl) (cadr ippl) (caddr ippl)) ipp))
    (setq ippl (cdddr ippl))
  )
  (setq ippl (vl-sort ipp '(lambda ( a b ) (< (vlax-curve-getparamatpoint ray a) (vlax-curve-getparamatpoint ray b)))))
  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (if (vlax-curve-getparamatpoint ent (car ippl))
      (setq e ent)
    )
  )
  (entdel ray)
  (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)))
  (*error* nil)
)

HTH, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 23 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-09-2016 04:02 AM

One more and I hope last info ab the code :

 

  (setq dx (/ (abs (- (car (cadr bb)) (car (car bb)))) 12.0))
  (setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 12.0))
  (setq ky 0)
  (repeat 11
    (setq ky (1+ ky))
    (setq kx 0)
    (repeat 11
      (setq kx (1+ kx))
      (setq pp (list (+ (car (car bb)) (* kx dx)) (+ (cadr (car bb)) (* ky dy)) 0.0))
      (if (and (/= kx 1) (/= ky 1) (/= kx 11) (/= ky 11))
        (setq pl (cons pp pl))
      )
    )
  )

Number of points for checking can be greater and that means and reliability of final result can be greater (not precision - just safety for determination of possible smaller boundary parts of boundary curve sel. set you aquire at start)...

 

And this can improve speed of execution... Like master Evgeniy said if you want to make routine fast, you should cut tree of algorithm if some criteria is fulfilled meaning no need for looping thorugh all list, just terminate it and start over with next outiside loop data...

 

    (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 a) (vlax-curve-getparamatpoint 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 a) (vlax-curve-getparamatpoint 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)
    )

So this is my latest revision and should work fast enough...

HTH, M.R.

 

Spoiler
Spoiler
(defun c:bndr ( / *error* unit bbucs *adoc* pea pck ss p bb dx dy kx ky pp ipp1 ipp2 ippl1 ippl2 rec pl pll li1 li2 i1 c1 i2 c2 ip ipl trl s el sx ii cx k e i ray ipp ippl )

  (vl-load-com)

  (defun *error* ( m )
    (if pea
      (setvar 'peditaccept pea)
    )
    (if pck
      (setvar 'pickbox pck)
    )
    (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 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)
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (setq pea (getvar 'peditaccept))
  (setvar 'peditaccept 1)
  (setq pck (getvar 'pickbox))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,CIRCLE,ELLIPSE"))))
  (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,CIRCLE,ELLIPSE"))))
  )
  (initget 1)
  (setq p (getpoint "\nPick or specify internal point : "))
  (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)))) 12.0))
  (setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 12.0))
  (setq ky 0)
  (repeat 11
    (setq ky (1+ ky))
    (setq kx 0)
    (repeat 11
      (setq kx (1+ kx))
      (setq pp (list (+ (car (car bb)) (* kx dx)) (+ (cadr (car bb)) (* ky dy)) 0.0))
      (if (and (/= kx 1) (/= ky 1) (/= kx 11) (/= ky 11))
        (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 (and (or (null ippl1) (= 0 (rem (length ippl1) 6))) (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 (vlax-invoke (vlax-ename->vla-object c1) 'intersectwith (vlax-ename->vla-object c2) acextendnone))
      (if (null ip)
        (cond
          ( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
            (setq ip (vlax-curve-getstartpoint c1))
          )
          ( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getendpoint c2) 1e-6)
            (setq ip (vlax-curve-getstartpoint c1))
          )
          ( (equal (vlax-curve-getendpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
            (setq ip (vlax-curve-getendpoint c1))
          )
          ( (equal (vlax-curve-getendpoint c1) (vlax-curve-getendpoint c2) 1e-6)
            (setq ip (vlax-curve-getendpoint c1))
          )
        )
      )
      (setq ipp (append ip 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 a) (vlax-curve-getparamatpoint 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 a) (vlax-curve-getparamatpoint 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)
  )
  (foreach tr trl
    (repeat (1- (length (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)))
      (setq trl (subst (list (car tr) (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tr)))) (caddr tr) t) tr trl))
    )
  )
  (foreach tr trl
    (if (eq (last tr) t)
      (entdel (cadr tr))
    )
  )
  (setq s (ssadd))
  (foreach tr (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (if
      (not
        (or
          (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6)
          (equal (vlax-curve-getendpoint (cadr tr)) (car tr) 1e-6)
        )
      )
      (progn
        (setq cx (entget (cadr tr)))
        (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001)))))) 0 1) "")
        (setq k 0)
        (while (equal cx (entget (cadr tr)) 1e-6)
          (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.1)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001))))))) 0 1) "")
        )
      )
    )
    (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
          (not
            (or
              (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (entlast)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (entlast)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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
          (not
            (or
              (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget e))
            (if (< (vlax-curve-getparamatpoint e (car tr)) (vlax-curve-getparamatpoint e (caddr tr)))
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.1) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.01) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.001) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.01)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.001)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (not
            (or
              (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (cadr tr)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (cadr tr)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
          )
        )
      )
    )
  )
  (foreach tr (vl-remove-if-not '(lambda ( x ) (eq (last x) t)) trl)
    (entdel (cadr tr))
    (setq el (entlast))
    (if
      (not
        (or
          (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6)
          (equal (vlax-curve-getendpoint (cadr tr)) (car tr) 1e-6)
        )
      )
      (progn
        (setq cx (entget (cadr tr)))
        (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001)))))) 0 1) "")
        (setq k 0)
        (while (equal cx (entget (cadr tr)) 1e-6)
          (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.1)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001))))))) 0 1) "")
        )
      )
    )
    (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
          (not
            (or
              (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (entlast)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (entlast)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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
          (not
            (or
              (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget e))
            (if (< (vlax-curve-getparamatpoint e (car tr)) (vlax-curve-getparamatpoint e (caddr tr)))
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.1) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.01) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.001) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.01)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.001)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (not
            (or
              (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (cadr tr)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (cadr tr)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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 (vl-some '(lambda ( x ) (if (wcmatch (cdr (assoc 0 (entget x))) "SPLINE,ELLIPSE") (setq e x))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
    (command "_.JOIN" e s "")
    (progn
      (command "_.PEDIT" "_M" s "" "_J" "_J" "_E" 0.0)
      (while (< 0 (getvar 'cmdactive))
        (command "")
      )
    )
  )
  (setq ray (entmakex (list '(0 . "RAY") '(100 . "AcDbEntity") '(100 . "AcDbRay") (cons 10 (trans p 1 0)) (cons 11 (getvar 'ucsxdir)))))
  (setq ss (ssget "_A"))
  (ssdel ray ss)
  (repeat (setq i (sslength ss))
    (setq e (ssname ss (setq i (1- i))))
    (setq ipp (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object e) acextendnone))
    (setq ippl (append ipp ippl))
  )
  (setq ipp nil)
  (repeat (/ (length ippl) 3)
    (setq ipp (cons (list (car ippl) (cadr ippl) (caddr ippl)) ipp))
    (setq ippl (cdddr ippl))
  )
  (setq ippl (vl-sort ipp '(lambda ( a b ) (< (vlax-curve-getparamatpoint ray a) (vlax-curve-getparamatpoint ray b)))))
  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (if (vlax-curve-getparamatpoint ent (car ippl))
      (setq e ent)
    )
  )
  (entdel ray)
  (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)))
  (*error* nil)
)
Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 24 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-09-2016 01:28 PM

It turns out that you have to explode POLYLINE entities and then proceed with routine... Also my latest researches showed me that it's better to use points that don't cross other entites for 2,4, and so on times, so your DWG with narrow gap won't be as desired as you clearly have more general cases where this corssings isn't desirable (two rectangles that corss each other - if you pick point on one side it won't recognize correct boundary - it's correct if you pick inbetween of rectangles, but there is no way to program routine both for narrow gaps and this situation)... At the end I must say that I also revised final gathering of entities - with poor implementation of JOIN command it's better to do it for newer ACAD releases with REGION command followed with CONVTOSURFACE and then OFFSETEDGE, but for releases that don't have those commands it's better to leave it to create final REGION - this is only if your selection contained SPLINE or ELLIPSE... Also I've exculded CIRCLE and full ELLPISE as they can't be trimmed correctly... Couldn't remove ELLIPSE from selection as you may have elliptical arc, but maybe the best is to remove buggus full ellipses or circles if they cross or create their corresponding arcs and proceed... This is all from me for now... We'll see how it'll behave in action, but this is all for simple cases with no ISLANDs and complex contouring... Regards, M.R.

 

Spoiler
(defun c:bndr ( / *error* unit bbucs *adoc* pea pck qaf ss p bb dx dy kx ky pp ipx ipp1 ipp2 ippl1 ippl2 rec pl pll li1 li2 i1 c1 i2 c2 ip ipl trl s el sx ii cx k e i ray ipp ippl )

  (vl-load-com)

  (defun *error* ( m )
    (if pea
      (setvar 'peditaccept pea)
    )
    (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 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)
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (setq pea (getvar 'peditaccept))
  (setvar 'peditaccept 1)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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 (/= (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 : "))
  (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)))) 21.0))
  (setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 21.0))
  (setq ky 0)
  (repeat 20
    (setq ky (1+ ky))
    (setq kx 0)
    (repeat 20
      (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 (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 a) (vlax-curve-getparamatpoint 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 a) (vlax-curve-getparamatpoint 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)
  )
  (foreach tr trl
    (repeat (1- (length (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)))
      (setq trl (subst (list (car tr) (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tr)))) (caddr tr) t) tr trl))
    )
  )
  (foreach tr trl
    (if (eq (last tr) t)
      (entdel (cadr tr))
    )
  )
  (setq s (ssadd))
  (foreach tr (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (if
      (not
        (or
          (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6)
          (equal (vlax-curve-getendpoint (cadr tr)) (car tr) 1e-6)
        )
      )
      (progn
        (setq cx (entget (cadr tr)))
        (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001)))))) 0 1) "")
        (setq k 0)
        (while (equal cx (entget (cadr tr)) 1e-6)
          (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.1)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001))))))) 0 1) "")
        )
      )
    )
    (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
          (not
            (or
              (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (entlast)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (entlast)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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
          (not
            (or
              (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget e))
            (if (< (vlax-curve-getparamatpoint e (car tr)) (vlax-curve-getparamatpoint e (caddr tr)))
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.1) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.01) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.001) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.01)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.001)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (not
            (or
              (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (cadr tr)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (cadr tr)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
          )
        )
      )
    )
  )
  (foreach tr (vl-remove-if-not '(lambda ( x ) (eq (last x) t)) trl)
    (entdel (cadr tr))
    (setq el (entlast))
    (if
      (not
        (or
          (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6)
          (equal (vlax-curve-getendpoint (cadr tr)) (car tr) 1e-6)
        )
      )
      (progn
        (setq cx (entget (cadr tr)))
        (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001)))))) 0 1) "")
        (setq k 0)
        (while (equal cx (entget (cadr tr)) 1e-6)
          (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.1)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001))))))) 0 1) "")
        )
      )
    )
    (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
          (not
            (or
              (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (entlast)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (entlast)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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
          (not
            (or
              (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget e))
            (if (< (vlax-curve-getparamatpoint e (car tr)) (vlax-curve-getparamatpoint e (caddr tr)))
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.1) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.01) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.001) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (equal cx (entget e) 1e-6)
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.01)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.001)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (not
            (or
              (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6)
              (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6)
            )
          )
          (progn
            (setq cx (entget (cadr tr)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (equal cx (entget (cadr tr)) 1e-6)
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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 (vl-some '(lambda ( x ) (if (wcmatch (cdr (assoc 0 (entget x))) "SPLINE,ELLIPSE") (setq e x))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
    (progn
      (setq p (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
      (command "_.REGION" s "")
      (command "_.CONVTOSURFACE" (entlast) "")
      (setq el (entlast))
      (command "_.OFFSETEDGE" "_non" p "_D" "0.0")
      (while (< 0 (getvar 'cmdactive))
        (command "")
      )
      (entdel el)
    )
    (progn
      (command "_.PEDIT" "_M" s "" "_J" "_J" "_E" 0.0)
      (while (< 0 (getvar 'cmdactive))
        (command "")
      )
    )
  )
  (setq ray (entmakex (list '(0 . "RAY") '(100 . "AcDbEntity") '(100 . "AcDbRay") (cons 10 (trans p 1 0)) (cons 11 (getvar 'ucsxdir)))))
  (setq ss (ssget "_A"))
  (ssdel ray ss)
  (repeat (setq i (sslength ss))
    (setq e (ssname ss (setq i (1- i))))
    (setq ipp (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object e) acextendnone))
    (setq ippl (append ipp ippl))
  )
  (setq ipp nil)
  (repeat (/ (length ippl) 3)
    (setq ipp (cons (list (car ippl) (cadr ippl) (caddr ippl)) ipp))
    (setq ippl (cdddr ippl))
  )
  (setq ippl (vl-sort ipp '(lambda ( a b ) (< (vlax-curve-getparamatpoint ray a) (vlax-curve-getparamatpoint ray b)))))
  (entdel ray)
  (setq e (ssname (ssget "_C" (car ippl) (car ippl)) 0))
  (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)))
  (*error* nil)
)
Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 25 of 71

АлексЮстасу
Advisor
Advisor
in reply to marko_ribar
‎06-09-2016 03:36 PM

What to do with the second fragment?


 
    (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)))
...
To add somewhere or to replace something?

-- Alexander, private person, pacifist, english only with translator 🙂 --

Object-modeling _ odclass-odedit.com _ Help

0 Likes
Like
Report
Message 26 of 71

marko_ribar
Advisor
Advisor
in reply to АлексЮстасу
‎06-09-2016 03:44 PM
@АлексЮстасу wrote:

What to do with the second fragment?


 
    (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)))
...
To add somewhere or to replace something?

Alex, I've already implemented that part in the code... Look into "Spoiler" roll button... Just click and you'll see my latest version... Look in my last post - last mark is "Spoiler"...

 

M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 27 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-10-2016 05:56 AM

Still buggus and unconsistent, but I've modified it futher... Added alert message and choice option and now prepared for only newer releases of ACAD (those that support CONVTOSURFACE and OFFSETEDGE commands)... Now I am tired, maybe someone will jump in with fresh thoughts... My previous version had zooming, but then I gave up with this - examples that used to work didn't and example with zooming on some case worked - it's unconsistent and beside I don't know in what scale DWG would be drawn... Regards, M.R.

 

Spoiler
(defun c:bndr ( / *error* unit bbucs *adoc* 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 sx ii cx k e i ray ipp ippl )

  (vl-load-com)

  (defun *error* ( m )
    (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 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)
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (setq pea (getvar 'peditaccept))
  (setvar 'peditaccept 1)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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)
    )
  )
  (alert "Internal point must be near one edge of boundary that doesn't overlap with next boundary...")
  (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")
  )
  (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)))) 16.0))
  (setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 16.0))
  (setq ky 0)
  (repeat 15
    (setq ky (1+ ky))
    (setq kx 0)
    (repeat 15
      (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 ) (< (distance (trans p 1 0) (vlax-curve-getpointatparam (cadr a) (/ (+ (vlax-curve-getparamatpoint (cadr a) (vlax-curve-getclosestpointto (cadr a) (car a))) (vlax-curve-getparamatpoint (cadr a) (vlax-curve-getclosestpointto (cadr a) (caddr a)))) 2.0))) (distance (trans p 1 0) (vlax-curve-getpointatparam (cadr b) (/ (+ (vlax-curve-getparamatpoint (cadr b) (vlax-curve-getclosestpointto (cadr b) (car b))) (vlax-curve-getparamatpoint (cadr b) (vlax-curve-getclosestpointto (cadr b) (caddr b)))) 2.0)))))))
  (setq k -1)
  (while (setq tr (nth (setq k (1+ k)) trl))
    (foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
      (if (not (equal tt tr 1e-6))
        (progn
          (setq trl (subst (list (car tt) (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))) (caddr tt) t) tt trl))
          (setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
        )
      )
    )
  )
  (foreach tt trl
    (if (eq (last tt) t)
      (entdel (cadr tt))
    )
  )
  (setq s (ssadd))
  (foreach tr (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (if
      (and
        (not
          (or
            (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6)
            (equal (vlax-curve-getendpoint (cadr tr)) (car tr) 1e-6)
          )
        )
        (> (sslength (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1))) 1)
      )
      (progn
        (setq cx (entget (cadr tr)))
        (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001)))))) 0 1) "")
        (setq k 0)
        (while (equal cx (entget (cadr tr)) 1e-6)
          (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.1)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001))))))) 0 1) "")
        )
      )
    )
    (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
              (or
                (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6)
                (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6)
              )
            )
            (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
          )
          (progn
            (setq cx (entget (entlast)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (or (equal cx (entget (entlast)) 1e-6) (not (or (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6) (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))))
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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
              (or
                (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6)
                (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6)
              )
            )
            (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
          )
          (progn
            (setq cx (entget e))
            (if (< (vlax-curve-getparamatpoint e (car tr)) (vlax-curve-getparamatpoint e (caddr tr)))
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (or (equal cx (entget e) 1e-6) (not (or (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6) (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))))
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.1) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.01) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.001) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (or (equal cx (entget e) 1e-6) (not (or (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6) (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))))
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.01)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.001)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (and
            (not
              (or
                (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6)
                (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
            (setq cx (entget (cadr tr)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (or (equal cx (entget (cadr tr)) 1e-6) (not (or (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6) (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))))
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
          )
        )
      )
    )
  )
  (foreach tt trl
    (if (and (eq (last tt) t) (vlax-erased-p (cadr tt)))
      (entdel (cadr tt))
    )
  )
  (foreach tr (vl-remove-if-not '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (if
      (and
        (not
          (or
            (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6)
            (equal (vlax-curve-getendpoint (cadr tr)) (car tr) 1e-6)
          )
        )
        (> (sslength (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1))) 1)
      )
      (progn
        (setq cx (entget (cadr tr)))
        (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.1) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.01) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.001)))))) 0 1) "")
        (setq k 0)
        (while (equal cx (entget (cadr tr)) 1e-6)
          (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.1)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.01)) (if (> (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001)) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) (* k 0.001))))))) 0 1) "")
        )
      )
    )
    (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
              (or
                (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6)
                (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6)
              )
            )
            (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
          )
          (progn
            (setq cx (entget (entlast)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (or (equal cx (entget (entlast)) 1e-6) (not (or (equal (vlax-curve-getstartpoint (entlast)) (caddr tr) 1e-6) (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))))
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (entlast) (vlax-curve-getpointatparam (entlast) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (entlast)) (vlax-curve-getparamatpoint (entlast) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (entlast) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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
              (or
                (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6)
                (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6)
              )
            )
            (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
          )
          (progn
            (setq cx (entget e))
            (if (< (vlax-curve-getparamatpoint e (car tr)) (vlax-curve-getparamatpoint e (caddr tr)))
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (or (equal cx (entget e) 1e-6) (not (or (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6) (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))))
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam e) (vlax-curve-getparamatpoint e (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
              (progn
                (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.1) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.1) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.01) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.01) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) 0.001) (- (vlax-curve-getparamatpoint e (caddr tr)) 0.001)))))) 0 1) "")
                (setq k 0)
                (while (or (equal cx (entget e) 1e-6) (not (or (equal (vlax-curve-getstartpoint e) (caddr tr) 1e-6) (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))))
                  (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto e (vlax-curve-getpointatparam e (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* (setq k (1+ k)) 0.1)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.01)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getparamatpoint e (caddr tr)) (vlax-curve-getstartparam e)) (* k 0.001)) (- (vlax-curve-getparamatpoint e (caddr tr)) (* k 0.001))))))) 0 1) "")
                )
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (and
            (not
              (or
                (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6)
                (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
            (setq cx (entget (cadr tr)))
            (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.1) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.1) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.01) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.01) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) 0.001) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.001)))))) 0 1) "")
            (setq k 0)
            (while (or (equal cx (entget (cadr tr)) 1e-6) (not (or (equal (vlax-curve-getstartpoint (cadr tr)) (caddr tr) 1e-6) (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))))
              (command "_.TRIM" "" "_nea" (trans (vlax-curve-getclosestpointto (cadr tr) (vlax-curve-getpointatparam (cadr tr) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* (setq k (1+ k)) 0.1)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.1)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.01)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.01)) (if (> (- (vlax-curve-getendparam (cadr tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr))) (* k 0.001)) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) (* k 0.001))))))) 0 1) "")
            )
          )
        )
        (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)
          )
        )
      )
    )
  )
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(lambda ( a b ) (< (distance (trans p 1 0) (vlax-curve-getclosestpointto a (trans p 1 0))) (distance (trans p 1 0) (vlax-curve-getclosestpointto b (trans p 1 0))))))))
  (setq pp (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
  (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)
    )
  )
  (command "_.REGION" s "")
  (setq s (ssget "_C" pp pp))
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(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)))
  (*error* nil)
)
Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 28 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-10-2016 05:15 PM

My latest optimized and concised version...

 

(defun c:bndr ( / *error* unit bbucs *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 sx ii k e i ray ipp ippl )

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

  (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" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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)
    )
  )
  (alert "Internal point must be near one edge of boundary that doesn't overlap with next boundary...")
  (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")
  )
  (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 ) (< (distance (trans p 1 0) (vlax-curve-getpointatparam (cadr a) (/ (+ (vlax-curve-getparamatpoint (cadr a) (vlax-curve-getclosestpointto (cadr a) (car a))) (vlax-curve-getparamatpoint (cadr a) (vlax-curve-getclosestpointto (cadr a) (caddr a)))) 2.0))) (distance (trans p 1 0) (vlax-curve-getpointatparam (cadr b) (/ (+ (vlax-curve-getparamatpoint (cadr b) (vlax-curve-getclosestpointto (cadr b) (car b))) (vlax-curve-getparamatpoint (cadr b) (vlax-curve-getclosestpointto (cadr b) (caddr b)))) 2.0)))))))
  (setq k -1)
  (while (setq tr (nth (setq k (1+ k)) trl))
    (foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
      (if (not (equal tt tr 1e-6))
        (progn
          (setq trl (subst (list (car tt) (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))) (caddr tt) t) tt trl))
          (setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
        )
      )
    )
  )
  (foreach tt trl
    (if (eq (last tt) t)
      (entdel (cadr tt))
    )
  )
  (setq s (ssadd))
  (foreach tr (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (if
      (and
        (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
        (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1) "")
        (setq k 0)
        (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
          (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 0 1) "")
        )
      )
    )
    (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 (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
            (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
          )
          (progn
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1) "")
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.0005))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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 (vlax-curve-getendpoint e) (caddr tr) 1e-6))
            (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
          )
          (progn
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1) "")
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.0005))) 0 1) "")
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (and
            (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 "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1) "")
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 0 1) "")
            )
          )
        )
        (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)
          )
        )
      )
    )
  )
  (foreach tt trl
    (if (and (eq (last tt) t) (vlax-erased-p (cadr tt)))
      (entdel (cadr tt))
    )
  )
  (foreach tr (vl-remove-if-not '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (if
      (and
        (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
        (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1) "")
        (setq k 0)
        (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
          (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 0 1) "")
        )
      )
    )
    (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 (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
            (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
          )
          (progn
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1) "")
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.0005))) 0 1) "")
            )
          )
        )
        (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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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 (vlax-curve-getendpoint e) (caddr tr) 1e-6))
            (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
          )
          (progn
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1) "")
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.0005))) 0 1) "")
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (if
          (and
            (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 "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1) "")
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 0 1) "")
            )
          )
        )
        (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)
          )
        )
      )
    )
  )
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(lambda ( a b ) (< (distance (trans p 1 0) (vlax-curve-getclosestpointto a (trans p 1 0))) (distance (trans p 1 0) (vlax-curve-getclosestpointto b (trans p 1 0))))))))
  (setq pp (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
  (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)
    )
  )
  (command "_.REGION" s "")
  (setq s (ssget "_C" pp pp))
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(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)))
  (*error* nil)
)

M.R.

Regards...

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 29 of 71

АлексЮстасу
Advisor
Advisor
in reply to marko_ribar
‎06-10-2016 06:39 PM

At first long thinks (the computer old), and then endlessly: trim, etc.
Or "*Invalid selection *"...

I think, need of a preliminary choice - already a problem...

I assumed long ago that the direct way isn't productive.

Possibly, for this task at first it is necessary to create special model of all file, the relations of the crossed lines, convenient for the fast analysis. And already on it to look for fragments of the lines forming the necessary boundary...


-- Alexander, private person, pacifist, english only with translator 🙂 --

Object-modeling _ odclass-odedit.com _ Help

0 Likes
Like
Report
Message 30 of 71

marko_ribar
Advisor
Advisor
in reply to АлексЮстасу
‎06-11-2016 09:07 AM
@АлексЮстасу wrote:

At first long thinks (the computer old), and then endlessly: trim, etc.
Or "*Invalid selection *"...

I think, need of a preliminary choice - already a problem...

I assumed long ago that the direct way isn't productive.

Possibly, for this task at first it is necessary to create special model of all file, the relations of the crossed lines, convenient for the fast analysis. And already on it to look for fragments of the lines forming the necessary boundary...

Alex, I worked further more on bugs you mentioned... This version is what I came up with, should be more consistent... Test it on your posted DWGs and passed...

 

(defun c:bndr ( / *error* unit bbucs *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 sx ii k e i ray ipp ippl )

  (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
      (progn
        (command "_.-VIEW" "_D" "{_VIEW_}")
        (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 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)
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (command "_.-VIEW" "_S" "{_VIEW_}")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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)
    )
  )
  (alert "Internal point must be near one edge of boundary that doesn't overlap with next boundary...")
  (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")
  )
  (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 ) (< (distance (trans p 1 0) (vlax-curve-getpointatparam (cadr a) (/ (+ (vlax-curve-getparamatpoint (cadr a) (vlax-curve-getclosestpointto (cadr a) (car a))) (vlax-curve-getparamatpoint (cadr a) (vlax-curve-getclosestpointto (cadr a) (caddr a)))) 2.0))) (distance (trans p 1 0) (vlax-curve-getpointatparam (cadr b) (/ (+ (vlax-curve-getparamatpoint (cadr b) (vlax-curve-getclosestpointto (cadr b) (car b))) (vlax-curve-getparamatpoint (cadr b) (vlax-curve-getclosestpointto (cadr b) (caddr b)))) 2.0)))))))
  (setq k -1)
  (while (setq tr (nth (setq k (1+ k)) trl))
    (foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
      (if (not (equal tt tr 1e-6))
        (progn
          (setq trl (subst (list (car tt) (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))) (caddr tt) t) tt trl))
          (setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
        )
      )
    )
  )
  (foreach tt trl
    (if (eq (last tt) t)
      (entdel (cadr tt))
    )
  )
  (setq s (ssadd))
  (foreach tr (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (command "_.-VIEW" "_R" "{_VIEW_}")
    (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
        (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) (list 1.0 1.0))))
        (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1))
        (while (< 0 (getvar 'cmdactive))
          (command "")
        )
        (setq k 0)
        (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
          (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) (list 1.0 1.0))))
          (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 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))
        )
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint (entlast)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint (entlast)) 0 1) (list 1.0 1.0))))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint (entlast)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint (entlast)) 0 1) (list 1.0 1.0))))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.0005))) 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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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))))))
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint e) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint e) 0 1) (list 1.0 1.0))))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint e) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint e) 0 1) (list 1.0 1.0))))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.0005))) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint (cadr tr)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint (cadr tr)) 0 1) (list 1.0 1.0))))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint (cadr tr)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint (cadr tr)) 0 1) (list 1.0 1.0))))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 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)
          )
        )
      )
    )
  )
  (foreach tt trl
    (if (and (eq (last tt) t) (vlax-erased-p (cadr tt)))
      (entdel (cadr tt))
    )
  )
  (foreach tr (vl-remove-if-not '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (command "_.-VIEW" "_R" "{_VIEW_}")
    (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
        (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) (list 1.0 1.0))))
        (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1))
        (while (< 0 (getvar 'cmdactive))
          (command "")
        )
        (setq k 0)
        (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
          (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) (list 1.0 1.0))))
          (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 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))
        )
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint (entlast)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint (entlast)) 0 1) (list 1.0 1.0))))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint (entlast)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint (entlast)) 0 1) (list 1.0 1.0))))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.0005))) 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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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))))))
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint e) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint e) 0 1) (list 1.0 1.0))))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint e) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint e) 0 1) (list 1.0 1.0))))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.0005))) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint (cadr tr)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint (cadr tr)) 0 1) (list 1.0 1.0))))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (mapcar '- (trans (vlax-curve-getendpoint (cadr tr)) 0 1) (list 1.0 1.0))) (vlax-3d-point (mapcar '+ (trans (vlax-curve-getendpoint (cadr tr)) 0 1) (list 1.0 1.0))))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 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)
          )
        )
      )
    )
  )
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(lambda ( a b ) (< (distance (trans p 1 0) (vlax-curve-getclosestpointto a (trans p 1 0))) (distance (trans p 1 0) (vlax-curve-getclosestpointto b (trans p 1 0))))))))
  (setq pp (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
  (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)
    )
  )
  (command "_.REGION" s "")
  (setq s (ssget "_C" pp pp))
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(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)))
  (*error* nil)
)

Regards, M.R.

HTH.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 31 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-11-2016 09:49 AM

Sorry, I made mistake in my last post... This is the version I should have posted...

 

(defun c:bndr ( / *error* unit bbucs *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 sx ii k e i ray ipp ippl )

  (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
      (progn
        (command "_.-VIEW" "_D" "{_VIEW_}")
        (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 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)
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (command "_.-VIEW" "_S" "{_VIEW_}")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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)
    )
  )
  (alert "Internal point must be near one edge of boundary that doesn't overlap with next boundary...")
  (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")
  )
  (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 ) (< (distance (trans p 1 0) (vlax-curve-getpointatparam (cadr a) (/ (+ (vlax-curve-getparamatpoint (cadr a) (vlax-curve-getclosestpointto (cadr a) (car a))) (vlax-curve-getparamatpoint (cadr a) (vlax-curve-getclosestpointto (cadr a) (caddr a)))) 2.0))) (distance (trans p 1 0) (vlax-curve-getpointatparam (cadr b) (/ (+ (vlax-curve-getparamatpoint (cadr b) (vlax-curve-getclosestpointto (cadr b) (car b))) (vlax-curve-getparamatpoint (cadr b) (vlax-curve-getclosestpointto (cadr b) (caddr b)))) 2.0)))))))
  (setq k -1)
  (while (setq tr (nth (setq k (1+ k)) trl))
    (foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
      (if (not (equal tt tr 1e-6))
        (progn
          (setq trl (subst (list (car tt) (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))) (caddr tt) t) tt trl))
          (setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
        )
      )
    )
  )
  (foreach tt trl
    (if (eq (last tt) t)
      (entdel (cadr tt))
    )
  )
  (setq s (ssadd))
  (foreach tr (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (command "_.-VIEW" "_R" "{_VIEW_}")
    (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
        (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
        (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1))
        (while (< 0 (getvar 'cmdactive))
          (command "")
        )
        (setq k 0)
        (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
          (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
          (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 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))
        )
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.0005))) 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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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))))))
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.0005))) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 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)
          )
        )
      )
    )
  )
  (foreach tt trl
    (if (and (eq (last tt) t) (vlax-erased-p (cadr tt)))
      (entdel (cadr tt))
    )
  )
  (foreach tr (vl-remove-if-not '(lambda ( x ) (eq (last x) t)) trl)
    (setq el (entlast))
    (command "_.-VIEW" "_R" "{_VIEW_}")
    (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
        (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
        (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1))
        (while (< 0 (getvar 'cmdactive))
          (command "")
        )
        (setq k 0)
        (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
          (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
          (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 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))
        )
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.0005))) 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)
                  )
                )
              )
            )
          )
        )
      )
      ( (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))))))
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.0005))) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
            )
          )
        )
        (ssadd e s)
      )
      ( t
        (command "_.-VIEW" "_R" "{_VIEW_}")
        (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
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
            (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
            (setq k 0)
            (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
              (command "_.TRIM" "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.0005))) 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)
          )
        )
      )
    )
  )
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(lambda ( a b ) (< (distance (trans p 1 0) (vlax-curve-getclosestpointto a (trans p 1 0))) (distance (trans p 1 0) (vlax-curve-getclosestpointto b (trans p 1 0))))))))
  (setq pp (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
  (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)
    )
  )
  (command "_.REGION" s "")
  (setq s (ssget "_C" pp pp))
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(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)))
  (*error* nil)
)

Sorry for mistake, HTH. M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 32 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-12-2016 02:31 AM

Developed further more... Should work fine and with example shown in picture...

 

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

  (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
      (progn
        (command "_.-VIEW" "_D" "{_VIEW_}")
        (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 sx )

    (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 sx (ssget "_C" (trans px 0 1) (trans px 0 1)))
      (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 / el k e sx ii entl )

    (vl-load-com)

    (foreach tr trll
      (setq el (entlast))
      (command "_.-VIEW" "_R" "{_VIEW_}")
      (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
          (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
          (command "_.ZOOM" "0.75xp")
          (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)
            )
          )
          (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1))
          (while (< 0 (getvar 'cmdactive))
            (command "")
          )
          (setq k 0)
          (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
            (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.05))) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
          )
          (if entl
            (foreach ent entl
              (if (vlax-erased-p ent)
                (entdel ent)
              )
            )
          )
        )
      )
      (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))
          )
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (entlast) (ssoverent (caddr tr) (vlax-curve-getendpoint (entlast)) (entlast)))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" (entlast) "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" (entlast) "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (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)
                    )
                  )
                )
              )
            )
          )
        )
        ( (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))))))
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel e (ssoverent (caddr tr) (vlax-curve-getendpoint e) e))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" e "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" e "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (ssadd e s)
        )
        ( t
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (cadr tr) (ssoverent (caddr tr) (vlax-curve-getendpoint (cadr tr)) (cadr tr)))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (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)
            )
          )
        )
      )
    )
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (command "_.-VIEW" "_S" "{_VIEW_}")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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")
  )
  (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))
              )
            )
          )
        )
      )
    )
  )
  (foreach tt trx
    (setq trl (vl-remove tt trl))
  )
  (setq trl (append trl (reverse trx)))
  (setq s (ssadd))
  (process (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl))
  (setq k 2)
  (repeat (- (apply 'max (mapcar 'length trl)) 3)
    (setq k (1+ k))
    (process (vl-remove-if-not '(lambda ( x ) (and (eq (nth k x) t) (null (nth (1+ k) x)))) trl))
  )

  (command "_.-VIEW" "_R" "{_VIEW_}")
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(lambda ( a b ) (< (distance (trans p 1 0) (vlax-curve-getclosestpointto a (trans p 1 0))) (distance (trans p 1 0) (vlax-curve-getclosestpointto b (trans p 1 0))))))))
  (setq pp (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
  (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)
    )
  )
  (command "_.REGION" s "")
  (setq s (ssget "_C" pp pp))
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(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)))
  (*error* nil)
)
Marko Ribar, d.i.a. (graduated engineer of architecture)
87 KB
0 Likes
Like
Report
Message 33 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-12-2016 03:08 AM

Sorry again I can't edit post... Here is what should be...

 

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

  (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
      (progn
        (command "_.-VIEW" "_D" "{_VIEW_}")
        (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 sx )

    (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 sx (ssget "_C" (trans px 0 1) (trans px 0 1)))
      (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 / el k e sx ii entl )

    (vl-load-com)

    (foreach tr trll
      (setq el (entlast))
      (command "_.-VIEW" "_R" "{_VIEW_}")
      (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
          (command "_.ZOOM" "_OB" (cadr tr) "")
          (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)
            )
          )
          (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1))
          (while (< 0 (getvar 'cmdactive))
            (command "")
          )
          (setq k 0)
          (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
            (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.05))) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
          )
          (if entl
            (foreach ent entl
              (if (vlax-erased-p ent)
                (entdel ent)
              )
            )
          )
        )
      )
      (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))
          )
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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 "_.ZOOM" "_OB" (entlast) "")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (entlast) (ssoverent (caddr tr) (vlax-curve-getendpoint (entlast)) (entlast)))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" (entlast) "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" (entlast) "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (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)
                    )
                  )
                )
              )
            )
          )
        )
        ( (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))))))
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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 "_.ZOOM" "_OB" e "")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel e (ssoverent (caddr tr) (vlax-curve-getendpoint e) e))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" e "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" e "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (ssadd e s)
        )
        ( t
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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 "_.ZOOM" "_OB" (cadr tr) "")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (cadr tr) (ssoverent (caddr tr) (vlax-curve-getendpoint (cadr tr)) (cadr tr)))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (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)
            )
          )
        )
      )
    )
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (command "_.-VIEW" "_S" "{_VIEW_}")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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")
  )
  (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))
              )
            )
          )
        )
      )
    )
  )
  (foreach tt trx
    (setq trl (vl-remove tt trl))
  )
  (setq trl (append trl (reverse trx)))
  (setq s (ssadd))
  (process (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl))
  (setq k 2)
  (repeat (- (apply 'max (mapcar 'length trl)) 3)
    (setq k (1+ k))
    (process (vl-remove-if-not '(lambda ( x ) (and (eq (nth k x) t) (null (nth (1+ k) x)))) trl))
  )

  (command "_.-VIEW" "_R" "{_VIEW_}")
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(lambda ( a b ) (< (distance (trans p 1 0) (vlax-curve-getclosestpointto a (trans p 1 0))) (distance (trans p 1 0) (vlax-curve-getclosestpointto b (trans p 1 0))))))))
  (setq pp (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
  (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)
    )
  )
  (command "_.REGION" s "")
  (setq s (ssget "_C" pp pp))
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(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)))
  (*error* nil)
)

P.S. Look into picture attached in previous post...

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 34 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-12-2016 03:45 AM

No it's not good, this is the one...

 

Actually the correct is previous one, but in sub function

 

(ssoverent)

 

should be

 

(if sx

  (repeat

    ...

  )

)

 

Spoiler
(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 )

  (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
      (progn
        (command "_.-VIEW" "_D" "{_VIEW_}")
        (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 sx )

    (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 sx (ssget "_C" (trans px 0 1) (trans px 0 1)))
      (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 / el k e sx ii entl )

    (vl-load-com)

    (foreach tr trll
      (setq el (entlast))
      (command "_.-VIEW" "_R" "{_VIEW_}")
      (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
          (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
          (command "_.ZOOM" "0.75xp")
          (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)
            )
          )
          (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.05)) 0 1))
          (while (< 0 (getvar 'cmdactive))
            (command "")
          )
          (setq k 0)
          (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
            (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.05))) 0 1))
            (while (< 0 (getvar 'cmdactive))
              (command "")
            )
          )
          (if entl
            (foreach ent entl
              (if (vlax-erased-p ent)
                (entdel ent)
              )
            )
          )
        )
      )
      (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))
          )
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (entlast) (ssoverent (caddr tr) (vlax-curve-getendpoint (entlast)) (entlast)))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" (entlast) "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" (entlast) "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (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)
                    )
                  )
                )
              )
            )
          )
        )
        ( (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))))))
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel e (ssoverent (caddr tr) (vlax-curve-getendpoint e) e))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" e "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" e "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (ssadd e s)
        )
        ( t
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (cadr tr) (ssoverent (caddr tr) (vlax-curve-getendpoint (cadr tr)) (cadr tr)))))))
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.05)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
                (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.05))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
          (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)
            )
          )
        )
      )
    )
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (command "_.-VIEW" "_S" "{_VIEW_}")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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")
  )
  (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))
              )
            )
          )
        )
      )
    )
  )
  (foreach tt trx
    (setq trl (vl-remove tt trl))
  )
  (setq trl (append trl (reverse trx)))
  (setq s (ssadd))
  (process (vl-remove-if '(lambda ( x ) (eq (last x) t)) trl))
  (setq k 2)
  (repeat (- (apply 'max (mapcar 'length trl)) 3)
    (setq k (1+ k))
    (process (vl-remove-if-not '(lambda ( x ) (and (eq (nth k x) t) (null (nth (1+ k) x)))) trl))
  )

  (command "_.-VIEW" "_R" "{_VIEW_}")
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(lambda ( a b ) (< (distance (trans p 1 0) (vlax-curve-getclosestpointto a (trans p 1 0))) (distance (trans p 1 0) (vlax-curve-getclosestpointto b (trans p 1 0))))))))
  (setq pp (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
  (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)
    )
  )
  (command "_.REGION" s "")
  (setq s (ssget "_C" pp pp))
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(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)))
  (*error* nil)
)
Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 35 of 71

АлексЮстасу
Advisor
Advisor
in reply to marko_ribar
‎06-12-2016 07:43 AM

In general becomes already obviously best of all. Though, and very long, but I understand that it is so far only a prototype.
Main thing now:
1. unpredictability of results.
Under approximately identical conditions and a points:
  -  noodles_1_no.png - if is specified to No for "Does boundary contour have narrow passage [Yes/No] <yes>: N"
  -  noodles_1_yes.png - is specified to Yes,
  -  noodles_2_yes.png - too is specified to Yes.
  -  noodles_2_no.png - is specified to No.
Perhaps, I specified a point closer to this or that line?
Still happens so:
  -  noodles_3_yes.png
  -  noodles_3_yes_delete.png - after deleting the created lines.
also there is * Invalid selection * - for example, for the same point in the No. mode.
2. doesn't find "islands". Or finds only them.
3. after all need to beforehand select objects can be defect. Repetition of results of BOUNDARY... 😞

 

.noodles_1_no.pngnoodles_1_yes.png

noodles_2_yes.pngnoodles_2_no.png

noodles_3_yes.png  noodles_3_yes_delete.png


-- Alexander, private person, pacifist, english only with translator 🙂 --

Object-modeling _ odclass-odedit.com _ Help

noodles.dwg
0 Likes
Like
Report
Message 36 of 71

marko_ribar
Advisor
Advisor
in reply to АлексЮстасу
‎06-12-2016 08:04 AM

Alex, you have to remove all islands, or put them on separate layer and freeze that layer... Then you start bndr.lsp and select objects (you may do "all"), then you pick internal point - no matter where just make sure that it's internal point, then you answer to the question but correct (yes - if there is narrow passage, or no - if it's clearly compound single portion of surrounding curves enclosing boundary... That's all - you may wait for it for a while to do the job, but it should return single entity (LWPOLYLINE or SPLINE - it must and should always be closed one)... Then thaw layer and repeat procedure for each island or course when finished with outer contouring... That's it - make sure you're using my last version - look into "Spoiler" pull down button... Regards, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 37 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-12-2016 08:16 AM

Just checked on your example and you're right... This line is missing :

(alert "Internal point must be near one edge of boundary that doesn't overlap with next boundary...")

Place it where it was before... M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 38 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-13-2016 06:54 AM

Latest version - even more stability... If something's wrong plese report - now should not break after those trimming...

 

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

  (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
      (progn
        (command "_.-VIEW" "_D" "{_VIEW_}")
        (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 )

    (vl-load-com)

    (foreach tr trll
      (setq el (entlast))
      (command "_.-VIEW" "_R" "{_VIEW_}")
      (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
          (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
          (command "_.ZOOM" "0.75xp")
          (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 "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) 0.01)) 0 1))
          (while (< 0 (getvar 'cmdactive))
            (command "")
          )
          (setq k 0)
          (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
            (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getstartpoint (cadr tr))) (vlax-3d-point (car tr)))
            (command "_.ZOOM" "0.75xp")
            (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getstartparam (cadr tr)) (* (setq k (1+ k)) 0.01))) 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))
          )
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (command "_.TRIM" "_ALL" "_R" (entlast) "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (entlast))) (vlax-3d-point (caddr tr)))
                (command "_.ZOOM" "0.75xp")
                (command "_.TRIM" "_ALL" "_R" (entlast) "" (trans (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) (* (setq k (1+ k)) 0.01))) 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)
              )
            )
          )
          (setq entl nil)
        )
        ( (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))))))
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (command "_.TRIM" "_ALL" "_R" e "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) 0.01)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint e)) (vlax-3d-point (caddr tr)))
                (command "_.ZOOM" "0.75xp")
                (command "_.TRIM" "_ALL" "_R" e "" (trans (vlax-curve-getpointatparam e (- (vlax-curve-getendparam e) (* (setq k (1+ k)) 0.01))) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
            )
          )
          (ssadd e s)
          (if entl
            (foreach ent entl
              (if (vlax-erased-p ent)
                (entdel ent)
              )
            )
          )
          (setq entl nil)
        )
        ( t
          (command "_.-VIEW" "_R" "{_VIEW_}")
          (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
              (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
              (command "_.ZOOM" "0.75xp")
              (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) 0.01)) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (setq k 0)
              (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
                (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point (vlax-curve-getendpoint (cadr tr))) (vlax-3d-point (caddr tr)))
                (command "_.ZOOM" "0.75xp")
                (command "_.TRIM" "_ALL" "_R" (cadr tr) "" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getendparam (cadr tr)) (* (setq k (1+ k)) 0.01))) 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)
              )
            )
          )
          (setq entl nil)
        )
      )
    )
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (command "_.-VIEW" "_S" "{_VIEW_}")
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" (list '(0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE") '(-4 . "<not") '(-4 . "<and") (cons 41 0.0) (cons 42 (* 2.0 pi)) '(-4 . "and>") '(-4 . "not>"))))
  )
  (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)
    )
  )
  (alert "Internal point must be near one edge of boundary that doesn't overlap with next boundary...")
  (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")
  )
  (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)
  )

  (command "_.-VIEW" "_R" "{_VIEW_}")
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(lambda ( a b ) (< (distance (trans p 1 0) (vlax-curve-getclosestpointto a (trans p 1 0))) (distance (trans p 1 0) (vlax-curve-getclosestpointto b (trans p 1 0))))))))
  (setq pp (trans (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)) 0 1))
  (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)
    )
  )
  (command "_.REGION" s "")
  (setq s (ssget "_C" pp pp))
  (setq e (car (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) '(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)))
  (*error* nil)
)

Regards, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 39 of 71

marko_ribar
Advisor
Advisor
in reply to marko_ribar
‎06-13-2016 09:51 AM

It buged me on trimming on one example... Just change inside (process) sub function in all occurances of (command "_.TRIM" ... ) factor from 0.01 to 0.05... Also no need to (setq entl nil) in ending of each (cond) statement inside (process) sub... Reply if you see something or if you have comment or important info...

 

Thanks, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
0 Likes
Like
Report
Message 40 of 71

АлексЮстасу
Advisor
Advisor
in reply to marko_ribar
‎06-13-2016 05:55 PM

I removed islands in the frozen layer:
  - noodles_no_no_islands.png - two boundary, but isn't complete ("Can't invoke...");
  - noodles_no_no_islands_delete.png - if to delete these boundary;
  - noodles_2_no_no_islands.png - is found not that boundary and isn't complete? "Cannot invoke...".

The related, in my opinion, problem - "fastest outline generator".
In my opinion, the general model of lines was for this purpose created. It is solved successfully, and works very quickly.

noodles_no_no_islands.png  noodles_no_no_islands_delete.png

 

noodles_2_no_no_islands.png


-- Alexander, private person, pacifist, english only with translator 🙂 --

Object-modeling _ odclass-odedit.com _ Help

0 Likes
Like
Report
Report a website issue