alternative of _BOUNDARY in the mode of pick point

[АлексЮстасу]

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.

[marko_ribar]

Alex, I have that plugin - Total Boundary, but this is only for outline boundaries - it doesn't work with picked internal point and if I may say it has some tolerance approximation of solution... Have you checked that your lines touch each other - with bndr.lsp there is no tolerances - everything must be desired - also your picked point like I've explained in (alert) message should be near edge that doesn't overlap with edge of adjacent boundary... Also check touching vertices of lines that meet at ends - select lines then click on end grip and move mouse - if preview shows both lines stretching then end is OK but if it shows only one line stretching then lines don't meet at end and you should modify them... If I may say so your example is consisted of this type of situations so recheck each vertex before bndr.lsp... Also if there is small crossings, better make it touching - trim it manually as bndr.lsp may fail to do this while trimming - sometime it still bugs with trim, but else is fine... Also make sure you're using my latest posted version and corrected code with my last post info... Regards, and if you really need it fast but not in all cases fine with splined curving then TBND is one way to do it... Still I'd firstly use BPOLY, then bndr.lsp and only then if I realy can't handle it which is really rare case I may use TBND, but I'd surely avoid it... M.R.

[marko_ribar]

Hi Alex, after studying how TRIM command behaves in comparison to BREAK command, I figured out that BREAK is much faster and more reliable... So I've changed bndr.lsp in that way that it's now faster and I've implemented full ellipse and circle entities as well... Still not 100% sure for CIRCLES and full ELLIPSES but I think that it's now much much better... I've tested it on few my and your examples and it passed tests... So I hope you can use it now as I think it's as much as LISP offers in such difficult task for LISP-ing... Regards, HTH, M.R.

(defun c:bndr ( / *error* unit bbucs ssoverent process *adoc* osm pck qaf ss p bb dx dy kx ky pp ipx ipp1 ipp2 ippl1 ippl2 rec ch pl pll li1 li2 i1 c1 i2 c2 ip ipl trl s el k e i ray ipp ippl kk cadrtt ttt trx trxx tx procl ti )

  (vl-load-com)

  (defun *error* ( m )
    (if osm
      (setvar 'osmode osm)
    )
    (if pck
      (setvar 'pickbox pck)
    )
    (if qaf
      (setvar 'qaflags qaf)
    )
    (vla-endundomark *adoc*)
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun unit ( v )
    (if (not (equal v '(0.0 0.0 0.0) 1e-6))
      (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
    )
  )

  (defun ssoverent ( sp ep ent / spar epar len k dx ssx px pxx pxxx sx sxx sxxx )

    (vl-load-com)

    (setq spar (vlax-curve-getparamatpoint ent sp))
    (setq epar (vlax-curve-getparamatpoint ent ep))
    (setq len (- (vlax-curve-getdistatparam ent epar) (vlax-curve-getdistatparam ent spar)))
    (setq k 0 dx (/ len 100.0) ssx (ssadd))
    (repeat 99
      (setq px (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (setq k (1+ k)) dx))))
      (setq pxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (+ k 0.5) dx))))
      (setq pxxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (- k 0.5) dx))))
      (setq sx (ssget "_C" (trans px 0 1) (trans px 0 1)))
      (setq sxx (ssget "_C" (trans pxx 0 1) (trans pxx 0 1)))
      (setq sxxx (ssget "_C" (trans pxxx 0 1) (trans pxxx 0 1)))
      (cond
        ( (and sx sxx sxxx)
          (if (not (vl-every '(lambda ( x ) (and (ssmemb x sxx) (ssmemb x sxxx))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
            (setq sx nil)
          )
        )
        ( (and sx sxx (not sxxx))
          (if (not (vl-every '(lambda ( x ) (ssmemb x sxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
            (setq sx nil)
          )
        )
        ( (and sx (not sxx) sxxx)
          (if (not (vl-every '(lambda ( x ) (ssmemb x sxxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
            (setq sx nil)
          )
        )
      )
      (if sx
        (repeat (setq ii (sslength sx))
          (ssadd (ssname sx (setq ii (1- ii))) ssx)
        )
      )
    )
    ssx
  )

  (defun bbucs ( ss / UCS2WCSMatrix WCS2UCSMatrix n ent minpt maxpt minptlst maxptlst minptbbx minptbby minptbbz minptbb maxptbbx maxptbby maxptbbz maxptbb )

    (vl-load-com)

    ;; Doug C. Broad, Jr.
    ;; can be used with vla-transformby to
    ;; transform objects from the UCS to the WCS
    (defun UCS2WCSMatrix ()
      (vlax-tmatrix
        (append
          (mapcar
           '(lambda (vector origin)
            (append (trans vector 1 0 t) (list origin))
          )
          (list '(1 0 0) '(0 1 0) '(0 0 1))
          (trans '(0 0 0) 0 1)
          )
          (list '(0 0 0 1))
        )
      )
    )
    ;; transform objects from the WCS to the UCS
    (defun WCS2UCSMatrix ()
      (vlax-tmatrix
        (append
          (mapcar
           '(lambda (vector origin)
            (append (trans vector 0 1 t) (list origin))
          )
          (list '(1 0 0) '(0 1 0) '(0 0 1))
          (trans '(0 0 0) 1 0)
          )
          (list '(0 0 0 1))
        )
      )
    )

    (if ss
      (progn
        (repeat (setq n (sslength ss))
          (setq ent (ssname ss (setq n (1- n))))
          (vla-TransformBy (vlax-ename->vla-object ent) (UCS2WCSMatrix))
          (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
          (vla-TransformBy (vlax-ename->vla-object ent) (WCS2UCSMatrix))
          (setq minpt (vlax-safearray->list minpoint))
          (setq maxpt (vlax-safearray->list maxpoint))
          (setq minptlst (cons minpt minptlst))
          (setq maxptlst (cons maxpt maxptlst))
        )
        (setq minptbbx (caar (vl-sort minptlst '(lambda (a b) (< (car a) (car b))))))
        (setq minptbby (cadar (vl-sort minptlst '(lambda (a b) (< (cadr a) (cadr b))))))
        (setq minptbbz (caddar (vl-sort minptlst '(lambda (a b) (< (caddr a) (caddr b))))))
        (setq maxptbbx (caar (vl-sort maxptlst '(lambda (a b) (> (car a) (car b))))))
        (setq maxptbby (cadar (vl-sort maxptlst '(lambda (a b) (> (cadr a) (cadr b))))))
        (setq maxptbbz (caddar (vl-sort maxptlst '(lambda (a b) (> (caddr a) (caddr b))))))
        (setq minptbb (list minptbbx minptbby minptbbz))
        (setq maxptbb (list maxptbbx maxptbby maxptbbz))
      )
    )
    (list minptbb maxptbb)
  )

  (defun process ( trll f / el k e sx ii entl np1 np2 d1 d2 )

    (vl-load-com)

    (foreach tr trll
      (if (and (wcmatch (cdr (assoc 0 (entget (cadr tr)))) "ELLIPSE,CIRCLE") (equal (vlax-curve-getstartpoint (cadr tr)) (vlax-curve-getendpoint (cadr tr)) 1e-6))
        (progn
          (setq np1 (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
          (setq np2 (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
          (setq d1 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np1)) pl)))
          (setq d2 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np2)) pl)))
          (if (< d1 d2)
            (progn
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
              (ssadd (ssname (ssget "_C" np1 np1) 0) s)
            )
            (progn
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
              (ssadd (ssname (ssget "_C" np2 np2) 0) s)
            )
          )
        )
        (progn
          (setq el (entlast))
          (if
            (and
              (not (equal (car tr) (caddr tr) 1e-6))
              (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
              (> (sslength (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1))) 1)
            )
            (progn
              (if f
                (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (cadr tr) (ssoverent (vlax-curve-getstartpoint (cadr tr)) (car tr) (cadr tr)))))))
              )
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (if (vlax-erased-p el)
                (setq el (entlast))
              )
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
                (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
            )
          )
          (cond
            ( (and (not (eq el (entlast))) (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr))))
              (if (not (eq (cadr tr) (entlast)))
                (entdel (cadr tr))
              )
              (if
                (and
                  (not (equal (car tr) (caddr tr) 1e-6))
                  (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
                  (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
                )
                (progn
                  (command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
                  (while (< 0 (getvar 'cmdactive))
                    (command "")
                  )
                  (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
                    (command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
                    (while (< 0 (getvar 'cmdactive))
                      (command "")
                    )
                  )
                )
              )
              (if (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
                (ssadd (entlast) s)
                (if (not (eq el (entlast)))
                  (progn
                    (entdel (entlast))
                    (if (not (vlax-erased-p (cadr tr)))
                      (ssadd (cadr tr) s)
                      (progn
                        (setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
                        (repeat (setq ii (sslength sx))
                          (if
                            (or
                              (and
                                (equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
                                (equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
                              )
                              (and
                                (equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
                                (equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
                              )
                            )
                            (ssadd (ssname sx ii) s)
                          )
                        )
                      )
                    )
                  )
                  (if (not (vlax-erased-p (cadr tr)))
                    (ssadd (cadr tr) s)
                    (progn
                      (setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
                      (repeat (setq ii (sslength sx))
                        (if
                          (or
                            (and
                              (equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
                              (equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
                            )
                            (and
                              (equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
                              (equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
                            )
                          )
                          (ssadd (ssname sx ii) s)
                        )
                      )
                    )
                  )
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
            ( (and (not (eq el (entlast))) (not (and (vlax-curve-getparamatpoint (cadr tr) (car tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr)))))
              (entdel (cadr tr))
              (setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
              (setq e (car (vl-remove-if-not '(lambda ( x ) (vlax-curve-getparamatpoint x (caddr tr))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx))))))
              (if
                (and
                  (not (equal (car tr) (caddr tr) 1e-6))
                  (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
                  (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
                )
                (progn
                  (command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
                  (while (< 0 (getvar 'cmdactive))
                    (command "")
                  )
                  (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
                    (command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
                    (while (< 0 (getvar 'cmdactive))
                      (command "")
                    )
                  )
                )
              )
              (ssadd e s)
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
            ( t
              (if
                (and
                  (not (equal (car tr) (caddr tr) 1e-6))
                  (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
                  (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
                )
                (progn
                  (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
                  (while (< 0 (getvar 'cmdactive))
                    (command "")
                  )
                  (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
                    (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
                    (while (< 0 (getvar 'cmdactive))
                      (command "")
                    )
                  )
                )
              )
              (if (and (not (eq el (entlast))) (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
                (ssadd (entlast) s)
                (if (not (eq el (entlast)))
                  (progn
                    (entdel (entlast))
                    (ssadd (cadr tr) s)
                  )
                  (ssadd (cadr tr) s)
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
        )
      )
    )
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
  )
  (setq sss (ssadd))
  (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (if (wcmatch (cdr (assoc 0 (entget e))) "~*POLYLINE")
      (ssadd e sss)
    )
  )
  (setvar 'qaflags 1)
  (command "_.EXPLODE" ss)
  (while (< 0 (getvar 'cmdactive))
    (command "")
  )
  (setq ss (ssget "_P"))
  (if (null ss)
    (setq ss (ssadd))
  )
  (if (/= (sslength sss) 0)
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex sss)))
      (ssadd e ss)
    )
  )
  (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")
  )
  (setq ti (car (_vl-times)))
  (setvar 'pickbox 1)
  (setq bb (bbucs ss))
  (setq bb (subst (list (car (car bb)) (cadr (car bb)) 0.0) (car bb) bb))
  (setq bb (subst (list (car (cadr bb)) (cadr (cadr bb)) 0.0) (cadr bb) bb))
  (setq dx (/ (abs (- (car (cadr bb)) (car (car bb)))) 11.0))
  (setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 11.0))
  (setq ky 0)
  (repeat 10
    (setq ky (1+ ky))
    (setq kx 0)
    (repeat 10
      (setq kx (1+ kx))
      (setq pp (list (+ (car (car bb)) (* kx dx)) (+ (cadr (car bb)) (* ky dy)) 0.0))
      (setq pl (cons pp pl))
    )
  )
  (setq rec
    (entmakex
      (list
        '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbPolyline")
        '(90 . 4)
        '(70 . 1)
        (cons 38 (caddr (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t))))
        (cons 10 (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
        (cons 10 (trans (list (car (cadr bb)) (cadr (car bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
        (cons 10 (trans (cadr bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
        (cons 10 (trans (list (car (car bb)) (cadr (cadr bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
        (cons 210 (trans '(0.0 0.0 1.0) 1 0 t))
      )
    )
  )
  (foreach pp pl
    (setq li1 (entmakex (list '(0 . "LINE") (cons 10 (trans p 1 0)) (cons 11 (trans pp 1 0)))))
    (setq li2 (entmakex (list '(0 . "LINE") (cons 10 (trans pp 1 0)) (cons 11 (vlax-curve-getclosestpointto rec (trans pp 1 0))))))
    (setq ippl1 nil ippl2 nil)
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i))))
      (setq ipp1 (vlax-invoke (vlax-ename->vla-object li1) 'intersectwith (vlax-ename->vla-object e) acextendnone))
      (setq ippl1 (append ipp1 ippl1))
      (setq ipp2 (vlax-invoke (vlax-ename->vla-object li2) 'intersectwith (vlax-ename->vla-object e) acextendnone))
      (setq ippl2 (append ipp2 ippl2))
    )
    (if (= ch "Yes")
      (if (and (or (null ippl1) (= 0 (rem (length ippl1) 6))) (not (null ippl2)))
        (setq pll (cons pp pll))
      )
      (if (and (null ippl1) (not (null ippl2)))
        (setq pll (cons pp pll))
      )
    )
    (entdel li1)
    (entdel li2)
  )
  (entdel rec)
  ;|
  (foreach pp pll
    (entmake (list '(0 . "POINT") (cons 10 (trans pp 1 0))))
  )
  |;
  (repeat (setq i1 (sslength ss))
    (setq c1 (ssname ss (setq i1 (1- i1))))
    (ssdel c1 ss)
    (repeat (setq i2 (sslength ss))
      (setq c2 (ssname ss (setq i2 (1- i2))))
      (setq ip nil pp nil ipx nil)
      (setq ip (vlax-invoke (vlax-ename->vla-object c1) 'intersectwith (vlax-ename->vla-object c2) acextendnone))
      (cond
        ( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
          (setq pp (vlax-curve-getstartpoint c1))
        )
        ( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getendpoint c2) 1e-6)
          (setq pp (vlax-curve-getstartpoint c1))
        )
        ( (equal (vlax-curve-getendpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
          (setq pp (vlax-curve-getendpoint c1))
        )
        ( (equal (vlax-curve-getendpoint c1) (vlax-curve-getendpoint c2) 1e-6)
          (setq pp (vlax-curve-getendpoint c1))
        )
      )
      (if ip
        (repeat (/ (length ip) 3)
          (setq ipx (cons (list (car ip) (cadr ip) (caddr ip)) ipx))
          (setq ip (cdddr ip))
        )
      )
      (if (and pp (not (vl-member-if '(lambda ( x ) (equal x pp 1e-6)) ipx)))
        (progn
          (setq ipp (append (apply 'append ipx) ipp))
          (setq ipp (append pp ipp))
        )
        (setq ipp (append (apply 'append ipx) ipp))
      )
    )
    (if ipp
      (repeat (/ (length ipp) 3)
        (setq ipl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ipl))
        (setq ipp (cdddr ipp))
      )
    )
    (setq ipl (vl-sort ipl '(lambda ( a b ) (< (vlax-curve-getparamatpoint c1 a) (vlax-curve-getparamatpoint c1 b)))))
    (mapcar
     '(lambda ( a b / loop k v ray ipp ippl )
        (setq loop t k -1)
        (while (and loop (setq pp (nth (setq k (1+ k)) pll)))
          (setq ippl nil)
          (setq v (unit (mapcar '- (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (trans pp 1 0))))
          (setq ray (entmakex (list '(0 . "RAY") '(100 . "AcDbEntity") '(100 . "AcDbRay") (cons 10 (trans pp 1 0)) (cons 11 v))))
          (setq ipp (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c1) acextendnone))
          (repeat (setq i2 (sslength ss))
            (setq c2 (ssname ss (setq i2 (1- i2))))
            (setq ipp (append (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c2) acextendnone) ipp))
          )
          (if ipp
            (repeat (/ (length ipp) 3)
              (setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
              (setq ipp (cdddr ipp))
            )
          )
          (if (equal (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (car (setq ippl (vl-sort ippl '(lambda ( a b ) (< (vlax-curve-getparamatpoint ray a) (vlax-curve-getparamatpoint ray b)))))) 1e-6)
            (if (not (vl-position (list a c1 b) trl))
              (setq trl (cons (list a c1 b) trl) loop nil)
            )
          )
          (entdel ray)
        )
      )
      ipl
      (cdr ipl)
    )
    (setq ipl nil)
    (ssadd c1 ss)
  )
  (setq trl (vl-sort trl '(lambda ( a b ) (< (vlax-curve-getparamatpoint (cadr a) (car a)) (vlax-curve-getparamatpoint (cadr b) (car b))))))
  (setq k -1)
  (while (setq tr (nth (setq k (1+ k)) trl))
    (setq kk -1)
    (if (not (or (eq (last tr) t) (eq (last tr) nil)))
      (foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
        (setq kk (1+ kk))
        (if (and (= kk 0) (> (length (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)) 1))
          (progn
            (setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
            (setq trx (cons (list (car tr) (cadr tr) (caddr tr) nil) trx))
          )
        )
        (if (> kk 0)
          (progn
            (setq cadrtt (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))))
            (setq ttt (list (car tt) cadrtt (caddr tt)))
            (if (not (equal tt tr 1e-6))
              (progn
                (setq trl
                  (subst
                    (repeat kk
                      (setq ttt (reverse (cons t (reverse ttt))))
                    )
                    tt
                    trl
                  )
                )
                (setq trx (cons ttt trx))
              )
            )
          )
        )
      )
    )
  )
  (setq trx (reverse trx))
  (foreach tt trx
    (setq trl (vl-remove tt trl))
  )
  (setq s (ssadd))
  (process trl nil)
  (foreach txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)
    (setq trxx (member txnil trx) procl nil)
    (while (and (setq tx (car trxx)) (not (equal tx (nth (1+ (vl-position txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx))) (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)) 1e-6)))
      (setq procl (cons tx procl))
      (setq trxx (cdr trxx))
    )
    (process (reverse procl) t)
  )

  (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)))
  (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  (*error* nil)
)

[АлексЮстасу]

Hi, Marko

Meanwhile unpredictability of results remains:
- noodles_yes_no_islands.png - the Yes mode, are for some reason outlined all by boundary - yellow;
- noodles_yes_no_islands_erase.png - after deleting these boudary;
- noodles_no_no_islands.png - the No mode, are created excess boudary;
- noodles_no_no_islands_erase.png - after deleting these boudary.
Between all lines there are no gaps, the island in other layer.

  

  

[marko_ribar]

Alex it seems that you are lazy to correct DWG for gaps... It didn't fail on my testings... Remove yellow LWPOLYLINE and use bndr.lsp again and pick point near right edge... It should after some time do Boundary polyline...

[АлексЮстасу]

I tested on a little other file, without gaps - applied.

[marko_ribar]

Test it again, I used your DWG, just removed ISLANDS on separate layer and picked point near right edge... I've changed color of LWPOLYLINE to yellow...

But I wanted to say that the code is now better then it was... Don't you agree?

[АлексЮстасу]

I specified point - where on screens the cursor. Yes, if to specify a point absolutely near the right edge, then boundary one and correct. This condition after all is strange.
Still I tried with other areas in the Yes mode - sometimes too finds other boundary:
- noodles_yes_no_islands_other.png;
- noodles_yes_no_islands_other_2.png.

  

The fact that in general it became better - undoubtedly.
But whether it will be possible in the principle better to make, than BOUNDARY?

[АлексЮстасу]

The file noodles_no_gaps.zip.txt isn't saved but only directly opens so:

For what this attached?

[marko_ribar]

Alex, you're right I shouldn't have posted that attachment... It doesn't allow me to attach *.DWG, so I ziped it and yet again it doesn't allow me to attach *.ZIP so I've renamed zip to txt... I'll try again with *.DWG... M.R.

This message appears :

Correct the highlighted errors and try again.

The attachment's noodles_no_gaps.dwg content type (unknown/unknown) does not match its file extension and has been removed.

Do you know how to bypass this?

[АлексЮстасу]

I attach dwg through Attachments:

[marko_ribar]

---

@АлексЮстасу wrote:

I attach dwg through Attachments:

---

I doing the same, but no avail... I even tried with all versions DWG-2000, DWG-2010, DWG-2013, always the same message...

[АлексЮстасу]

Can be to use other browser?
Or, maybe, the antivirus locks?

[marko_ribar]

Testing with new browser and without virus shields...

[АлексЮстасу]

Why you read the marked areas islands? They are not separate?

Why in case of such pick point finds the wrong boundary?

   

[marko_ribar]

Alex, if you study the code, you'll see that at the end routine is determining smallest region from set of regions that are created, and if you pick point near edge of boundary that's adjacent to next boundary, routine will take smaller of those two... You should read carefully what written in alert message and do exactly what's written... It's the only way to do it correct - this is the difference from BPOLY or BOUNDARY command, but that couldn't be avoided... Hope it's clearer now... M.R.

[АлексЮстасу]

Marko, but why the smallest boundary is selected, but not that in which pick point? Same contradicts the task?

[marko_ribar]

---

@АлексЮстасу wrote:

Marko, but why the smallest boundary is selected, but not that in which pick point? Same contradicts the task?

---

I know that this is contradictory, but the reason lies in fact that it is very likely when you select many curve entities after new selection set is calculated when REGION command is issued there will be created more than one REGION entity... So to avoid confusion only one smallest REGION that is overlapping with other one in the point that's closest to picked point is taken in consideration for next COPYBASE, UNDO, PASTECLIP commands...

[marko_ribar]

As a matter a fact, you made me think twice on this problem... Maybe the solution is actually in making XLINE and collect 2 selection sets of REGIONS at points of intersection with them at each opposite point... Then we simply check for common REGION entity from both selection sets - the one that belongs to both of them is solution... So if you are willing to modify the code, do it and check if the solution LWPOLYLINE or SPLINE derived from REGION that I mentioned satisfies internal point as user input parameter...

[marko_ribar]

I was correct in my last reply and I was faster, + for me... Ha, ha... Now without (alert) message, just pick internal point...

(defun c:bndr ( / *error* unit bbucs ssoverent process *adoc* osm pck qaf ss p bb dx dy kx ky pp ipx ipp1 ipp2 ippl1 ippl2 rec ch pl pll li1 li2 i1 c1 i2 c2 ip ipl trl s el k e i ray ipp ippl kk cadrtt ttt trx trxx tx procl xli reg ssreg s1 s2 ppl pp1 pp2 ti )

  (vl-load-com)

  (defun *error* ( m )
    (if osm
      (setvar 'osmode osm)
    )
    (if pck
      (setvar 'pickbox pck)
    )
    (if qaf
      (setvar 'qaflags qaf)
    )
    (vla-endundomark *adoc*)
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun unit ( v )
    (if (not (equal v '(0.0 0.0 0.0) 1e-6))
      (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
    )
  )

  (defun ssoverent ( sp ep ent / spar epar len k dx ssx px pxx pxxx sx sxx sxxx )

    (vl-load-com)

    (setq spar (vlax-curve-getparamatpoint ent sp))
    (setq epar (vlax-curve-getparamatpoint ent ep))
    (setq len (- (vlax-curve-getdistatparam ent epar) (vlax-curve-getdistatparam ent spar)))
    (setq k 0 dx (/ len 100.0) ssx (ssadd))
    (repeat 99
      (setq px (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (setq k (1+ k)) dx))))
      (setq pxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (+ k 0.5) dx))))
      (setq pxxx (vlax-curve-getpointatdist ent (+ (vlax-curve-getdistatparam ent spar) (* (- k 0.5) dx))))
      (setq sx (ssget "_C" (trans px 0 1) (trans px 0 1)))
      (setq sxx (ssget "_C" (trans pxx 0 1) (trans pxx 0 1)))
      (setq sxxx (ssget "_C" (trans pxxx 0 1) (trans pxxx 0 1)))
      (cond
        ( (and sx sxx sxxx)
          (if (not (vl-every '(lambda ( x ) (and (ssmemb x sxx) (ssmemb x sxxx))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
            (setq sx nil)
          )
        )
        ( (and sx sxx (not sxxx))
          (if (not (vl-every '(lambda ( x ) (ssmemb x sxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
            (setq sx nil)
          )
        )
        ( (and sx (not sxx) sxxx)
          (if (not (vl-every '(lambda ( x ) (ssmemb x sxxx)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx)))))
            (setq sx nil)
          )
        )
      )
      (if sx
        (repeat (setq ii (sslength sx))
          (ssadd (ssname sx (setq ii (1- ii))) ssx)
        )
      )
    )
    ssx
  )

  (defun bbucs ( ss / UCS2WCSMatrix WCS2UCSMatrix n ent minpt maxpt minptlst maxptlst minptbbx minptbby minptbbz minptbb maxptbbx maxptbby maxptbbz maxptbb )

    (vl-load-com)

    ;; Doug C. Broad, Jr.
    ;; can be used with vla-transformby to
    ;; transform objects from the UCS to the WCS
    (defun UCS2WCSMatrix ()
      (vlax-tmatrix
        (append
          (mapcar
           '(lambda (vector origin)
            (append (trans vector 1 0 t) (list origin))
          )
          (list '(1 0 0) '(0 1 0) '(0 0 1))
          (trans '(0 0 0) 0 1)
          )
          (list '(0 0 0 1))
        )
      )
    )
    ;; transform objects from the WCS to the UCS
    (defun WCS2UCSMatrix ()
      (vlax-tmatrix
        (append
          (mapcar
           '(lambda (vector origin)
            (append (trans vector 0 1 t) (list origin))
          )
          (list '(1 0 0) '(0 1 0) '(0 0 1))
          (trans '(0 0 0) 1 0)
          )
          (list '(0 0 0 1))
        )
      )
    )

    (if ss
      (progn
        (repeat (setq n (sslength ss))
          (setq ent (ssname ss (setq n (1- n))))
          (vla-TransformBy (vlax-ename->vla-object ent) (UCS2WCSMatrix))
          (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
          (vla-TransformBy (vlax-ename->vla-object ent) (WCS2UCSMatrix))
          (setq minpt (vlax-safearray->list minpoint))
          (setq maxpt (vlax-safearray->list maxpoint))
          (setq minptlst (cons minpt minptlst))
          (setq maxptlst (cons maxpt maxptlst))
        )
        (setq minptbbx (caar (vl-sort minptlst '(lambda (a b) (< (car a) (car b))))))
        (setq minptbby (cadar (vl-sort minptlst '(lambda (a b) (< (cadr a) (cadr b))))))
        (setq minptbbz (caddar (vl-sort minptlst '(lambda (a b) (< (caddr a) (caddr b))))))
        (setq maxptbbx (caar (vl-sort maxptlst '(lambda (a b) (> (car a) (car b))))))
        (setq maxptbby (cadar (vl-sort maxptlst '(lambda (a b) (> (cadr a) (cadr b))))))
        (setq maxptbbz (caddar (vl-sort maxptlst '(lambda (a b) (> (caddr a) (caddr b))))))
        (setq minptbb (list minptbbx minptbby minptbbz))
        (setq maxptbb (list maxptbbx maxptbby maxptbbz))
      )
    )
    (list minptbb maxptbb)
  )

  (defun process ( trll f / el k e sx ii entl np1 np2 d1 d2 )

    (vl-load-com)

    (foreach tr trll
      (if (and (wcmatch (cdr (assoc 0 (entget (cadr tr)))) "ELLIPSE,CIRCLE") (equal (vlax-curve-getstartpoint (cadr tr)) (vlax-curve-getendpoint (cadr tr)) 1e-6))
        (progn
          (setq np1 (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
          (setq np2 (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)))
          (setq d1 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np1)) pl)))
          (setq d2 (apply '+ (mapcar '(lambda ( x ) (distance (trans x 1 0) np2)) pl)))
          (if (< d1 d2)
            (progn
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
              (ssadd (ssname (ssget "_C" np1 np1) 0) s)
            )
            (progn
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (+ (vlax-curve-getparamatpoint (cadr tr) (car tr)) 0.05)) 0 1) "_non" (trans (car tr) 0 1))
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getpointatparam (cadr tr) (- (vlax-curve-getparamatpoint (cadr tr) (caddr tr)) 0.05)) 0 1) "_non" (trans (caddr tr) 0 1))
              (ssadd (ssname (ssget "_C" np2 np2) 0) s)
            )
          )
        )
        (progn
          (setq el (entlast))
          (if
            (and
              (not (equal (car tr) (caddr tr) 1e-6))
              (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
              (> (sslength (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1))) 1)
            )
            (progn
              (if f
                (setq entl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssdel (cadr tr) (ssoverent (vlax-curve-getstartpoint (cadr tr)) (car tr) (cadr tr)))))))
              )
              (if entl
                (foreach ent entl
                  (entdel ent)
                )
              )
              (if (vlax-erased-p el)
                (setq el (entlast))
              )
              (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
              (while (< 0 (getvar 'cmdactive))
                (command "")
              )
              (while (not (equal (vlax-curve-getstartpoint (cadr tr)) (car tr) 1e-6))
                (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getstartpoint (cadr tr)) 0 1) "_non" (trans (car tr) 0 1))
                (while (< 0 (getvar 'cmdactive))
                  (command "")
                )
              )
            )
          )
          (cond
            ( (and (not (eq el (entlast))) (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr))))
              (if (not (eq (cadr tr) (entlast)))
                (entdel (cadr tr))
              )
              (if
                (and
                  (not (equal (car tr) (caddr tr) 1e-6))
                  (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
                  (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
                )
                (progn
                  (command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
                  (while (< 0 (getvar 'cmdactive))
                    (command "")
                  )
                  (while (not (equal (vlax-curve-getendpoint (entlast)) (caddr tr) 1e-6))
                    (command "_.BREAK" (entlast) "_nea" (trans (vlax-curve-getendpoint (entlast)) 0 1) "_non" (trans (caddr tr) 0 1))
                    (while (< 0 (getvar 'cmdactive))
                      (command "")
                    )
                  )
                )
              )
              (if (and (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
                (ssadd (entlast) s)
                (if (not (eq el (entlast)))
                  (progn
                    (entdel (entlast))
                    (if (not (vlax-erased-p (cadr tr)))
                      (ssadd (cadr tr) s)
                      (progn
                        (setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
                        (repeat (setq ii (sslength sx))
                          (if
                            (or
                              (and
                                (equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
                                (equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
                              )
                              (and
                                (equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
                                (equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
                              )
                            )
                            (ssadd (ssname sx ii) s)
                          )
                        )
                      )
                    )
                  )
                  (if (not (vlax-erased-p (cadr tr)))
                    (ssadd (cadr tr) s)
                    (progn
                      (setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
                      (repeat (setq ii (sslength sx))
                        (if
                          (or
                            (and
                              (equal (vlax-curve-getstartpoint (ssname sx (setq ii (1- ii)))) (car tr) 1e-6)
                              (equal (vlax-curve-getendpoint (ssname sx ii)) (caddr tr) 1e-6)
                            )
                            (and
                              (equal (vlax-curve-getstartpoint (ssname sx ii)) (caddr tr) 1e-6)
                              (equal (vlax-curve-getendpoint (ssname sx ii)) (car tr) 1e-6)
                            )
                          )
                          (ssadd (ssname sx ii) s)
                        )
                      )
                    )
                  )
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
            ( (and (not (eq el (entlast))) (not (and (vlax-curve-getparamatpoint (cadr tr) (car tr)) (vlax-curve-getparamatpoint (cadr tr) (caddr tr)))))
              (entdel (cadr tr))
              (setq sx (ssget "_C" (trans (car tr) 0 1) (trans (car tr) 0 1)))
              (setq e (car (vl-remove-if-not '(lambda ( x ) (vlax-curve-getparamatpoint x (caddr tr))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sx))))))
              (if
                (and
                  (not (equal (car tr) (caddr tr) 1e-6))
                  (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
                  (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
                )
                (progn
                  (command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
                  (while (< 0 (getvar 'cmdactive))
                    (command "")
                  )
                  (while (not (equal (vlax-curve-getendpoint e) (caddr tr) 1e-6))
                    (command "_.BREAK" e "_nea" (trans (vlax-curve-getendpoint e) 0 1) "_non" (trans (caddr tr) 0 1))
                    (while (< 0 (getvar 'cmdactive))
                      (command "")
                    )
                  )
                )
              )
              (ssadd e s)
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
            ( t
              (if
                (and
                  (not (equal (car tr) (caddr tr) 1e-6))
                  (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
                  (> (sslength (ssget "_C" (trans (caddr tr) 0 1) (trans (caddr tr) 0 1))) 1)
                )
                (progn
                  (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
                  (while (< 0 (getvar 'cmdactive))
                    (command "")
                  )
                  (while (not (equal (vlax-curve-getendpoint (cadr tr)) (caddr tr) 1e-6))
                    (command "_.BREAK" (cadr tr) "_nea" (trans (vlax-curve-getendpoint (cadr tr)) 0 1) "_non" (trans (caddr tr) 0 1))
                    (while (< 0 (getvar 'cmdactive))
                      (command "")
                    )
                  )
                )
              )
              (if (and (not (eq el (entlast))) (vlax-curve-getparamatpoint (entlast) (car tr)) (vlax-curve-getparamatpoint (entlast) (caddr tr)))
                (ssadd (entlast) s)
                (if (not (eq el (entlast)))
                  (progn
                    (entdel (entlast))
                    (ssadd (cadr tr) s)
                  )
                  (ssadd (cadr tr) s)
                )
              )
              (if entl
                (foreach ent entl
                  (if (vlax-erased-p ent)
                    (entdel ent)
                  )
                )
              )
            )
          )
        )
      )
    )
  )

  (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
  (setq osm (getvar 'osmode))
  (setvar 'osmode 0)
  (setq pck (getvar 'pickbox))
  (setq qaf (getvar 'qaflags))
  (prompt "\nSelect boundary curve entities...")
  (setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
  (while (not ss)
    (prompt "\nSource curve boundary sel. set empty... Please reselect boundary curves on unlocked layer(s) again...")
    (setq ss (ssget "_:L" '((0 . "*POLYLINE,LINE,SPLINE,ARC,ELLIPSE,CIRCLE"))))
  )
  (setq sss (ssadd))
  (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (if (wcmatch (cdr (assoc 0 (entget e))) "~*POLYLINE")
      (ssadd e sss)
    )
  )
  (setvar 'qaflags 1)
  (command "_.EXPLODE" ss)
  (while (< 0 (getvar 'cmdactive))
    (command "")
  )
  (setq ss (ssget "_P"))
  (if (null ss)
    (setq ss (ssadd))
  )
  (if (/= (sslength sss) 0)
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex sss)))
      (ssadd e ss)
    )
  )
  (initget 1)
  (setq p (getpoint "\nPick or specify internal point : "))
  (initget "Yes No")
  (setq ch (getkword "\nDoes boundary contour have narrow passage [Yes/No] <Yes> : "))
  (if (null ch)
    (setq ch "Yes")
  )
  (setq ti (car (_vl-times)))
  (setvar 'pickbox 1)
  (setq bb (bbucs ss))
  (setq bb (subst (list (car (car bb)) (cadr (car bb)) 0.0) (car bb) bb))
  (setq bb (subst (list (car (cadr bb)) (cadr (cadr bb)) 0.0) (cadr bb) bb))
  (setq dx (/ (abs (- (car (cadr bb)) (car (car bb)))) 11.0))
  (setq dy (/ (abs (- (cadr (cadr bb)) (cadr (car bb)))) 11.0))
  (setq ky 0)
  (repeat 10
    (setq ky (1+ ky))
    (setq kx 0)
    (repeat 10
      (setq kx (1+ kx))
      (setq pp (list (+ (car (car bb)) (* kx dx)) (+ (cadr (car bb)) (* ky dy)) 0.0))
      (setq pl (cons pp pl))
    )
  )
  (setq rec
    (entmakex
      (list
        '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbPolyline")
        '(90 . 4)
        '(70 . 1)
        (cons 38 (caddr (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t))))
        (cons 10 (trans (car bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
        (cons 10 (trans (list (car (cadr bb)) (cadr (car bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
        (cons 10 (trans (cadr bb) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
        (cons 10 (trans (list (car (car bb)) (cadr (cadr bb))) 1 (trans '(0.0 0.0 1.0) 1 0 t)))
        (cons 210 (trans '(0.0 0.0 1.0) 1 0 t))
      )
    )
  )
  (foreach pp pl
    (setq li1 (entmakex (list '(0 . "LINE") (cons 10 (trans p 1 0)) (cons 11 (trans pp 1 0)))))
    (setq li2 (entmakex (list '(0 . "LINE") (cons 10 (trans pp 1 0)) (cons 11 (vlax-curve-getclosestpointto rec (trans pp 1 0))))))
    (setq ippl1 nil ippl2 nil)
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i))))
      (setq ipp1 (vlax-invoke (vlax-ename->vla-object li1) 'intersectwith (vlax-ename->vla-object e) acextendnone))
      (setq ippl1 (append ipp1 ippl1))
      (setq ipp2 (vlax-invoke (vlax-ename->vla-object li2) 'intersectwith (vlax-ename->vla-object e) acextendnone))
      (setq ippl2 (append ipp2 ippl2))
    )
    (if (= ch "Yes")
      (if (and (or (null ippl1) (= 0 (rem (length ippl1) 6))) (not (null ippl2)))
        (setq pll (cons pp pll))
      )
      (if (and (null ippl1) (not (null ippl2)))
        (setq pll (cons pp pll))
      )
    )
    (entdel li1)
    (entdel li2)
  )
  (entdel rec)
  ;|
  (foreach pp pll
    (entmake (list '(0 . "POINT") (cons 10 (trans pp 1 0))))
  )
  |;
  (repeat (setq i1 (sslength ss))
    (setq c1 (ssname ss (setq i1 (1- i1))))
    (ssdel c1 ss)
    (repeat (setq i2 (sslength ss))
      (setq c2 (ssname ss (setq i2 (1- i2))))
      (setq ip nil pp nil ipx nil)
      (setq ip (vlax-invoke (vlax-ename->vla-object c1) 'intersectwith (vlax-ename->vla-object c2) acextendnone))
      (cond
        ( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
          (setq pp (vlax-curve-getstartpoint c1))
        )
        ( (equal (vlax-curve-getstartpoint c1) (vlax-curve-getendpoint c2) 1e-6)
          (setq pp (vlax-curve-getstartpoint c1))
        )
        ( (equal (vlax-curve-getendpoint c1) (vlax-curve-getstartpoint c2) 1e-6)
          (setq pp (vlax-curve-getendpoint c1))
        )
        ( (equal (vlax-curve-getendpoint c1) (vlax-curve-getendpoint c2) 1e-6)
          (setq pp (vlax-curve-getendpoint c1))
        )
      )
      (if ip
        (repeat (/ (length ip) 3)
          (setq ipx (cons (list (car ip) (cadr ip) (caddr ip)) ipx))
          (setq ip (cdddr ip))
        )
      )
      (if (and pp (not (vl-member-if '(lambda ( x ) (equal x pp 1e-6)) ipx)))
        (progn
          (setq ipp (append (apply 'append ipx) ipp))
          (setq ipp (append pp ipp))
        )
        (setq ipp (append (apply 'append ipx) ipp))
      )
    )
    (if ipp
      (repeat (/ (length ipp) 3)
        (setq ipl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ipl))
        (setq ipp (cdddr ipp))
      )
    )
    (setq ipl (vl-sort ipl '(lambda ( a b ) (< (vlax-curve-getparamatpoint c1 a) (vlax-curve-getparamatpoint c1 b)))))
    (mapcar
     '(lambda ( a b / loop k v ray ipp ippl )
        (setq loop t k -1)
        (while (and loop (setq pp (nth (setq k (1+ k)) pll)))
          (setq ippl nil)
          (setq v (unit (mapcar '- (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (trans pp 1 0))))
          (setq ray (entmakex (list '(0 . "RAY") '(100 . "AcDbEntity") '(100 . "AcDbRay") (cons 10 (trans pp 1 0)) (cons 11 v))))
          (setq ipp (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c1) acextendnone))
          (repeat (setq i2 (sslength ss))
            (setq c2 (ssname ss (setq i2 (1- i2))))
            (setq ipp (append (vlax-invoke (vlax-ename->vla-object ray) 'intersectwith (vlax-ename->vla-object c2) acextendnone) ipp))
          )
          (if ipp
            (repeat (/ (length ipp) 3)
              (setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
              (setq ipp (cdddr ipp))
            )
          )
          (if (equal (vlax-curve-getpointatparam c1 (/ (+ (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 a)) (vlax-curve-getparamatpoint c1 (vlax-curve-getclosestpointto c1 b))) 2.0)) (car (setq ippl (vl-sort ippl '(lambda ( a b ) (< (vlax-curve-getparamatpoint ray a) (vlax-curve-getparamatpoint ray b)))))) 1e-6)
            (if (not (vl-position (list a c1 b) trl))
              (setq trl (cons (list a c1 b) trl) loop nil)
            )
          )
          (entdel ray)
        )
      )
      ipl
      (cdr ipl)
    )
    (setq ipl nil)
    (ssadd c1 ss)
  )
  (setq trl (vl-sort trl '(lambda ( a b ) (< (vlax-curve-getparamatpoint (cadr a) (car a)) (vlax-curve-getparamatpoint (cadr b) (car b))))))
  (setq k -1)
  (while (setq tr (nth (setq k (1+ k)) trl))
    (setq kk -1)
    (if (not (or (eq (last tr) t) (eq (last tr) nil)))
      (foreach tt (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)
        (setq kk (1+ kk))
        (if (and (= kk 0) (> (length (vl-remove-if-not '(lambda ( x ) (eq (cadr tr) (cadr x))) trl)) 1))
          (progn
            (setq trl (subst (list (car tr) (cadr tr) (caddr tr) nil) tr trl))
            (setq trx (cons (list (car tr) (cadr tr) (caddr tr) nil) trx))
          )
        )
        (if (> kk 0)
          (progn
            (setq cadrtt (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object (cadr tt)))))
            (setq ttt (list (car tt) cadrtt (caddr tt)))
            (if (not (equal tt tr 1e-6))
              (progn
                (setq trl
                  (subst
                    (repeat kk
                      (setq ttt (reverse (cons t (reverse ttt))))
                    )
                    tt
                    trl
                  )
                )
                (setq trx (cons ttt trx))
              )
            )
          )
        )
      )
    )
  )
  (setq trx (reverse trx))
  (foreach tt trx
    (setq trl (vl-remove tt trl))
  )
  (setq s (ssadd))
  (process trl nil)
  (foreach txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)
    (setq trxx (member txnil trx) procl nil)
    (while (and (setq tx (car trxx)) (not (equal tx (nth (1+ (vl-position txnil (vl-remove-if-not '(lambda ( x ) (null (last x))) trx))) (vl-remove-if-not '(lambda ( x ) (null (last x))) trx)) 1e-6)))
      (setq procl (cons tx procl))
      (setq trxx (cdr trxx))
    )
    (process (reverse procl) t)
  )

  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
    (setq ss (ssget "_C" (trans (vlax-curve-getstartpoint ent) 0 1) (trans (vlax-curve-getstartpoint ent) 0 1)))
    (repeat (setq i (sslength ss))
      (ssadd (ssname ss (setq i (1- i))) s)
    )
    (setq ss (ssget "_C" (trans (vlax-curve-getendpoint ent) 0 1) (trans (vlax-curve-getendpoint ent) 0 1)))
    (repeat (setq i (sslength ss))
      (ssadd (ssname ss (setq i (1- i))) s)
    )
  )
  (setq el (entlast))
  (command "_.REGION" s "")
  (setq xli (entmakex (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 (trans p 1 0)) (cons 11 (trans '(1.0 0.0 0.0) 1 0 t)))))
  (setq ssreg (ssadd))
  (while (setq el (entnext el))
    (ssadd el ssreg)
  )
  (repeat (setq i (sslength ssreg))
    (setq reg (ssname ssreg (setq i (1- i))))
    (setq ip (vlax-invoke (vlax-ename->vla-object xli) 'intersectwith (vlax-ename->vla-object reg) acextendnone))
    (setq ipl (append ip ipl))
  )
  (repeat (/ (length ipl) 3)
    (setq ppl (cons (list (car ipl) (cadr ipl) (caddr ipl)) ppl))
    (setq ipl (cdddr ipl))
  )
  (setq pp1 (car (vl-sort ppl '(lambda ( a b ) (< (distance (trans p 1 0) a) (distance (trans p 1 0) b))))))
  (setq ppl (vl-remove-if '(lambda ( x ) (equal (unit (mapcar '- x (trans p 1 0))) (unit (mapcar '- pp1 (trans p 1 0))) 1e-6)) ppl))
  (setq pp2 (car (vl-sort ppl '(lambda ( a b ) (< (distance (trans p 1 0) a) (distance (trans p 1 0) b))))))
  (setq s1 (ssget "_C" pp1 pp1 '((0 . "REGION"))))
  (setq s2 (ssget "_C" pp2 pp2 '((0 . "REGION"))))
  (entdel xli)
  (foreach reg (vl-remove-if 'listp (mapcar 'cadr (ssnamex s1)))
    (if (ssmemb reg s2)
      (setq e reg)
    )
  )
  (command "_.CONVTOSURFACE" e "")
  (setq el (entlast))
  (command "_.OFFSETEDGE" "_non" pp "_D" "0.0")
  (while (< 0 (getvar 'cmdactive))
    (command "")
  )
  (entdel el)
  (setq e (entlast))
  (command "_.COPYBASE" "_non" '(0.0 0.0 0.0) e "")
  (command "_.UNDO" "_B")
  (command "_.PASTECLIP" "_non" '(0.0 0.0 0.0))
  (sssetfirst nil (ssadd (entlast)))
  (prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
  (*error* nil)
)

Regards, M.R.

[marko_ribar]

I missed something :

This :

  (setq s1 (ssget "_C" pp1 pp1 '((0 . "REGION"))))
  (setq s2 (ssget "_C" pp2 pp2 '((0 . "REGION"))))

Should be :

  (setq s1 (ssget "_C" (trans pp1 0 1) (trans pp1 0 1) '((0 . "REGION"))))
  (setq s2 (ssget "_C" (trans pp2 0 1) (trans pp2 0 1) '((0 . "REGION"))))

Sorry, I was in rush...

M.R.