Generate Boundary Line By Selecting Intersecting lines

August 28, 2018

Here is a simple 'proof-of-concept' routine.

Please change the dis value to suit your plans.

Explode the inserts that have resulted from using the _Measure command. If you use a unique layer for the nested line the temporary objects can later easily be selected and erased.

And make sure to zoom in on the selection.

(defun KGA_Conv_Pickset_To_ObjectList (ss / i ret)
  (if ss
    (repeat (setq i (sslength ss))
      (setq ret (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) ret))
    )
  )
)

(defun KGA_Geom_MidPoint (pt1 pt2)
  (mapcar '/ (mapcar '+ pt1 pt2) '(2.0 2.0 2.0))
)

(defun CreateBorder (fronObj backObj sideObj / dis fronPt backPt)
  (setq dis 1.0) ; Change value to for example 1/10th of average width of lot.
  (if
    (and
      (setq fronPt (vlax-invoke fronObj 'intersectwith sideObj acextendnone))
      (= 3 (length fronPt))
      (setq backPt (vlax-invoke backObj 'intersectwith sideObj acextendnone))
      (= 3 (length backPt))
    )
    (progn
      (command
        "_.bpoly"
        "_non"
        (polar
          (KGA_Geom_MidPoint fronPt backPt)
          (+ (angle fronPt backPt) (* 0.5 pi))
          dis
        )
        ""
      )
    )
  )
)

(defun c:Test ( / backObj doc fronObj sideObjLst ss)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-endundomark doc)
  (vla-startundomark doc)
  (if
    (and
      (setq fronObj (car (entsel "\nFront edge of lots: ")))
      (setq backObj (car (entsel "\nBack edge of lots: ")))
      (princ "\nSide edges of lots: ")
      (setq ss (ssget '((0 . "LINE"))))
    )
    (progn
      (setq
        fronObj (vlax-ename->vla-object fronObj)
        backObj (vlax-ename->vla-object backObj)
        sideObjLst (KGA_Conv_Pickset_To_ObjectList ss)
      )
      (setvar 'cmdecho 0)
      (foreach sideObj sideObjLst
        (CreateBorder fronObj backObj sideObj)
      )
      (setvar 'cmdecho 1)
    )
  )
  (vla-endundomark doc)
  (princ)
)

Edited August 28, 2018 by Roy_043

August 28, 2018

On 8/27/2018 at 4:32 PM, loudy000 said:

no worries see attached if you want to have a look at it. Cheers!

Enclosed polylines.LSP

Let's see if we can pimp that one

On 8/27/2018 at 11:00 AM, Stefan BMR said:

You can try the Enclosed Polylines.lsp from here.

Hi Stefan! Very clever piece of coding there! I'm not sure if the version loody attached is your latest version, but I noticed that the 1rst line makes the 2nd line bomb. (*acDoc* is define on the 1rst line while the 2nd uses an undefined variable acDoc).

Now, lets see what I can do with it with some matrix functions kindly made available by Vladimir Nesterovsky, Doug Wilson and Gile... (Merci Gilles. Tu es un mentor et une source d'inspiration même à une distance de probablement plusieurs fuseaux horaires!)

Not bad, heh?

On 8/21/2018 at 11:00 AM, loudy000 said:

That's awesome but too expensive

Soooo! If 14$ is too expensive, tell us how much you think would be a fair price? (ie not too expensive....). I'm wondering how much our time is worth to someone who will get the credit for an increased productivity. At least a "like" I hope.
Enjoy

(defun dupfromins (ent parentlst / tmpnam tmplst newitm); duplst and ss as global here, local to c:ecl
  ;ent is insert
  ;(eq "INSERT" (cdr (assoc 0 (entget ent))))
  ;Jef! 2018-08-28
  (if (null parentlst) (setq parentlst (cons ent parentlst)))
  (setq ent (tblobjname "block" (cdr (assoc 2 (entget ent)))))
  (while (setq ent (entnext ent))
         (cond ((member (setq tmpnam (cdr(assoc 0 (setq tmplst (entget ent))))) '("LINE" "LWPOLYLINE" "ARC" "CIRCLE"))
                (vla-transformby
                  (vlax-ename->vla-object
                    (setq newitm
                      (entmakex
                        (append (vl-remove-if '(lambda (x) (member (car x) '(-1 330 5))) tmplst) (list (cons 410(getvar 'ctab))))
                      )
                    )
                  )
                  (vlax-tmatrix (get-tmatrix parentlst))
                )
                ;(setq duplst (cons (vlax-ename->vla-object newitm) duplst))
                (setq duplst (cons newitm duplst))
                (ssadd newitm ss)
               )
               ((eq "INSERT" tmpnam)
                (dupfromins ent (cons ent parentlst))
               )
         )
  )
)
;;;;;;;;
;helper functions to the helper function ^^


;; Get-TMatrix (gile)
;; Retourne une matrice de transformation (4X4) identique à celle retournée par nentselp
;;
;; Argument
;; lst : (liste de ENAME) la liste des entités "parents" de la plus imbriqué à celle
;; insérée dans l'espace courant -indentique à (last (nentsel)) ou (last (nentselp))

(defun get-tmatrix (lst / mat pt geom)
  (setq	mat (Imat 3)
	pt  '(0.0 0.0 0.0)
  )
  (while lst
    (setq geom (refgeom (car lst))
	  mat  (mxm (car geom) mat)
	  pt   (mapcar '+ (mxv (car geom) pt) (cadr geom))
	  lst  (cdr lst)
    )
  )
  (append
    (mapcar '(lambda (v x) (append v (list x))) mat pt)
    (list '(0.0 0.0 0.0 1.0))
  )
)

;; IMAT
;; Crée une matrice d'identité de dimension n
;;
;; Argument
;; n : la dimension de la matrice

(defun Imat (d / i n r m)
  (setq i d)
  (while (<= 0 (setq i (1- i)))
    (setq n d r nil)
    (while (<= 0 (setq n (1- n)))
      (setq r (cons (if (= i n) 1.0 0.0) r))
    )
    (setq m (cons r m))
  )
)

;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
;; Arguments: a 3X3 matrix and a vector
;; Return : the vecor transformed by the matrix

(defun mxv (m v)
  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)

;; TRP
;; transpose une matrice -Doug Wilson-
;;
;; Argument : une matrice

(defun trp (m) (apply 'mapcar (cons 'list m)))

;; MXM
;; Multiple (combine) deux matrices -Vladimir Nesterovsky-
;;
;; Arguments : deux matrices

(defun mxm (m q)
  (mapcar '(lambda (r) (mxv (trp q) r)) m)
)

;; RefGeom (gile)
;; Retourne une liste dont le premier élément est une matrice de transformation
;; (rotation, échelles, normale) de dimension 3X3 et le second le point
;; d'insertion de l'objet dans son "parent" (xref, bloc ou espace)

(defun RefGeom (ename / elst ang norm mat)
  (setq	elst (entget ename)
	ang  (cdr (assoc 50 elst))
	norm (cdr (assoc 210 elst))
  )
  (list
    (setq mat
	   (mxm
	     (mapcar (function (lambda (v) (trans v 0 norm T)))
		     '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
	     )
	     (mxm
	       (list (list (cos ang) (- (sin ang)) 0.0)
		     (list (sin ang) (cos ang) 0.0)
		     '(0.0 0.0 1.0)
	       )
	       (list (list (cdr (assoc 41 elst)) 0.0 0.0)
		     (list 0.0 (cdr (assoc 42 elst)) 0.0)
		     (list 0.0 0.0 (cdr (assoc 43 elst)))
	       )
	     )
	   )
    )
    (mapcar
      '-
      (trans (cdr (assoc 10 elst)) norm 0)
      (mxv mat
	   (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst)))))
      )
    )
  )
)

;;;;;;;;;;;;;;
;main function

(defun c:ECL ( / *error* i lst ms r1 reg ss sysvar prop duplst)
  ;modified by Jef! on 2018-08-28 to also work with blocks
  ;warning: doesnt verify if block inserts are uniformaly scaled
  ;but who uses non uniformaly scaled blocks anyway? :)
  (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
  (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
  (vla-startundomark acDoc)
  (setq pa (getvar 'peditaccept)
        dr (getvar 'draworderctl)
        ce (getvar 'cmdecho)
        aa 0.00
  )
  
  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
      (princ (strcat "\nError: " msg))
      )
    (foreach x segments (vla-delete x))
    (setvar 'peditaccept pa)
    (setvar 'draworderctl dr)
    (setvar 'cmdecho ce)
    (vla-endundomark acDoc)
    (princ)
    )
  (defun l2p (l) (if l (cons (list (car l) (cadr l) (caddr l)) (l2p (cdddr l)))))
  
  (defun break_object (e points / object_type start center end radius normal arc res)
    (if points
      (progn
        (setq points
          (vl-sort points
            (function
              (lambda (a b)
                (<
                  (vlax-curve-getdistatpoint e a)
                  (vlax-curve-getdistatpoint e b)
                )
              )
            )
          )
        )
        (cond
          ((eq (setq object_type (vla-get-ObjectName e)) "AcDbLine")
           (setq start (vlax-curve-getstartpoint e))
           (while points
             (if (> (distance start (car points)) 1e-8)
               (setq res (cons (vlax-invoke ms 'addline start (setq start (car points))) res))
               )
             (setq points (cdr points))
             )
           )
          (T
           (if
             (eq object_type "AcDbArc")
             (setq start  (vlax-curve-getStartParam e))
             (setq start  (vlax-curve-getparamatpoint e (car points))
                   points (reverse (cons (car points) (reverse (cdr points))))
             )
           )
           (setq   center (vla-get-Center e)
                   radius (vla-get-Radius e)
                   normal (vla-get-Normal e)
           )
           (while points
             (if (not (equal start (setq end (vlax-curve-getparamatpoint e (car points))) 1e-8))
               (progn
                 (setq arc (vla-AddArc ms center radius start end))
                 (vla-put-Normal arc normal)
                 (setq res (cons arc res))
               )
             )
             (setq points (cdr points)
                   start end)
             )
           )
         )
       )
     )
    res
  )
         
  (if
    (setq ss (ssget ":L" '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE,INSERT"))));added insert (Jef!)
    (progn
      (repeat (setq i (sslength ss));added by Jef!
        (setq i (1- i)
              e (ssname ss i)
              )
        (if (eq "INSERT" (cdr (assoc 0 (entget e))))
            (progn
              (dupfromins e nil)
              (ssdel e ss)
              )
          )
        
      );end added by Jef!
      (repeat (setq i (sslength ss))
        (setq i (1- i)
              e (ssname ss i)
              e (vlax-ename->vla-object e)
              )
        (if
          (eq (vla-get-ObjectName e) "AcDbPolyline")
          (foreach x (vlax-invoke e 'Explode)
            (setq lst (cons x lst))
            )
          (setq lst (cons (vla-copy e) lst))
        )
      )
      (if
        (setq segments
          (apply 'append
            (mapcar
              (function
                (lambda (e / l)
                  (break_object e
                    (progn
                      (foreach other (vl-remove e lst)
                        (foreach x (l2p (vlax-invoke e 'intersectwith other acExtendNone))
                           (setq l (cons x l))
                        )
                      )
                      (if
                        (eq (vla-get-ObjectName e) "AcDbCircle")
                        l
                        (cons (vlax-curve-getendpoint e) l)
                      )
                    )
                  )
                )
              )
              lst
            )
          )
        )
        (progn
          (setq reg (vlax-invoke ms 'AddRegion segments))
          (foreach x (append segments lst) (vla-delete x))
          (setvar 'peditaccept 1)
          (setvar 'draworderctl 0)
          (setvar 'cmdecho 0)
          (foreach x reg
            (setq x (vlax-vla-object->ename x))
            (command "_explode" x)
            (command "_pedit" "_m" "_p" "" "_j" "" "")
            (if (> (vlax-curve-getArea (entlast)) aa) (setq aa (vlax-curve-getArea (setq ea (entlast)))))
            )
          (if (> (length reg) 1) (entdel ea))
          (if duplst (mapcar 'entdel duplst));added by Jef!
          (setvar 'peditaccept pa)
          (setvar 'draworderctl dr)
          (setvar 'cmdecho ce)
        )
        (princ "\nValid region(s) not found")
      )
    )
  )
  (vla-endundomark acDoc)
  (princ)
)

Cheers!

August 29, 2018

46 minutes ago, Jef! said:

Let's see if we can pimp that one

Hi Stefan! Very clever piece of coding there! I'm not sure if the version loody attached is your latest version, but I noticed that the 1rst line makes the 2nd line bomb. (*acDoc* is define on the 1rst line while the 2nd uses an undefined variable acDoc).

Now, lets see what I can do with it with some matrix functions kindly made available by Vladimir Nesterovsky, Doug Wilson and Gile... (Merci Gilles. Tu es un mentor et une source d'inspiration même à une distance de probablement plusieurs fuseaux horaires!)

Not bad, heh?

Soooo! If 14$ is too expensive, tell us how much you think would be a fair price? (ie not too expensive....). I'm wondering how much our time is worth to someone who will get the credit for an increased productivity. At least a "like" I hope.
Enjoy


(defun dupfromins (ent parentlst / tmpnam tmplst newitm); duplst and ss as global here, local to c:ecl
  ;ent is insert
  ;(eq "INSERT" (cdr (assoc 0 (entget ent))))
  ;Jef! 2018-08-28
  (if (null parentlst) (setq parentlst (cons ent parentlst)))
  (setq ent (tblobjname "block" (cdr (assoc 2 (entget ent)))))
  (while (setq ent (entnext ent))
         (cond ((member (setq tmpnam (cdr(assoc 0 (setq tmplst (entget ent))))) '("LINE" "LWPOLYLINE" "ARC" "CIRCLE"))
                (vla-transformby
                  (vlax-ename->vla-object
                    (setq newitm
                      (entmakex
                        (append (vl-remove-if '(lambda (x) (member (car x) '(-1 330 5))) tmplst) (list (cons 410(getvar 'ctab))))
                      )
                    )
                  )
                  (vlax-tmatrix (get-tmatrix parentlst))
                )
                ;(setq duplst (cons (vlax-ename->vla-object newitm) duplst))
                (setq duplst (cons newitm duplst))
                (ssadd newitm ss)
               )
               ((eq "INSERT" tmpnam)
                (dupfromins ent (cons ent parentlst))
               )
         )
  )
)
;;;;;;;;
;helper functions to the helper function ^^


;; Get-TMatrix (gile)
;; Retourne une matrice de transformation (4X4) identique à celle retournée par nentselp
;;
;; Argument
;; lst : (liste de ENAME) la liste des entités "parents" de la plus imbriqué à celle
;; insérée dans l'espace courant -indentique à (last (nentsel)) ou (last (nentselp))

(defun get-tmatrix (lst / mat pt geom)
  (setq	mat (Imat 3)
	pt  '(0.0 0.0 0.0)
  )
  (while lst
    (setq geom (refgeom (car lst))
	  mat  (mxm (car geom) mat)
	  pt   (mapcar '+ (mxv (car geom) pt) (cadr geom))
	  lst  (cdr lst)
    )
  )
  (append
    (mapcar '(lambda (v x) (append v (list x))) mat pt)
    (list '(0.0 0.0 0.0 1.0))
  )
)

;; IMAT
;; Crée une matrice d'identité de dimension n
;;
;; Argument
;; n : la dimension de la matrice

(defun Imat (d / i n r m)
  (setq i d)
  (while (<= 0 (setq i (1- i)))
    (setq n d r nil)
    (while (<= 0 (setq n (1- n)))
      (setq r (cons (if (= i n) 1.0 0.0) r))
    )
    (setq m (cons r m))
  )
)

;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
;; Arguments: a 3X3 matrix and a vector
;; Return : the vecor transformed by the matrix

(defun mxv (m v)
  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)

;; TRP
;; transpose une matrice -Doug Wilson-
;;
;; Argument : une matrice

(defun trp (m) (apply 'mapcar (cons 'list m)))

;; MXM
;; Multiple (combine) deux matrices -Vladimir Nesterovsky-
;;
;; Arguments : deux matrices

(defun mxm (m q)
  (mapcar '(lambda (r) (mxv (trp q) r)) m)
)

;; RefGeom (gile)
;; Retourne une liste dont le premier élément est une matrice de transformation
;; (rotation, échelles, normale) de dimension 3X3 et le second le point
;; d'insertion de l'objet dans son "parent" (xref, bloc ou espace)

(defun RefGeom (ename / elst ang norm mat)
  (setq	elst (entget ename)
	ang  (cdr (assoc 50 elst))
	norm (cdr (assoc 210 elst))
  )
  (list
    (setq mat
	   (mxm
	     (mapcar (function (lambda (v) (trans v 0 norm T)))
		     '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
	     )
	     (mxm
	       (list (list (cos ang) (- (sin ang)) 0.0)
		     (list (sin ang) (cos ang) 0.0)
		     '(0.0 0.0 1.0)
	       )
	       (list (list (cdr (assoc 41 elst)) 0.0 0.0)
		     (list 0.0 (cdr (assoc 42 elst)) 0.0)
		     (list 0.0 0.0 (cdr (assoc 43 elst)))
	       )
	     )
	   )
    )
    (mapcar
      '-
      (trans (cdr (assoc 10 elst)) norm 0)
      (mxv mat
	   (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst)))))
      )
    )
  )
)

;;;;;;;;;;;;;;
;main function

(defun c:ECL ( / *error* i lst ms r1 reg ss sysvar prop duplst)
  ;modified by Jef! on 2018-08-28 to also work with blocks
  ;warning: doesnt verify if block inserts are uniformaly scaled
  ;but who uses non uniformaly scaled blocks anyway? :)
  (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
  (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
  (vla-startundomark acDoc)
  (setq pa (getvar 'peditaccept)
        dr (getvar 'draworderctl)
        ce (getvar 'cmdecho)
        aa 0.00
  )
  
  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
      (princ (strcat "\nError: " msg))
      )
    (foreach x segments (vla-delete x))
    (setvar 'peditaccept pa)
    (setvar 'draworderctl dr)
    (setvar 'cmdecho ce)
    (vla-endundomark acDoc)
    (princ)
    )
  (defun l2p (l) (if l (cons (list (car l) (cadr l) (caddr l)) (l2p (cdddr l)))))
  
  (defun break_object (e points / object_type start center end radius normal arc res)
    (if points
      (progn
        (setq points
          (vl-sort points
            (function
              (lambda (a b)
                (<
                  (vlax-curve-getdistatpoint e a)
                  (vlax-curve-getdistatpoint e b)
                )
              )
            )
          )
        )
        (cond
          ((eq (setq object_type (vla-get-ObjectName e)) "AcDbLine")
           (setq start (vlax-curve-getstartpoint e))
           (while points
             (if (> (distance start (car points)) 1e-8)
               (setq res (cons (vlax-invoke ms 'addline start (setq start (car points))) res))
               )
             (setq points (cdr points))
             )
           )
          (T
           (if
             (eq object_type "AcDbArc")
             (setq start  (vlax-curve-getStartParam e))
             (setq start  (vlax-curve-getparamatpoint e (car points))
                   points (reverse (cons (car points) (reverse (cdr points))))
             )
           )
           (setq   center (vla-get-Center e)
                   radius (vla-get-Radius e)
                   normal (vla-get-Normal e)
           )
           (while points
             (if (not (equal start (setq end (vlax-curve-getparamatpoint e (car points))) 1e-8))
               (progn
                 (setq arc (vla-AddArc ms center radius start end))
                 (vla-put-Normal arc normal)
                 (setq res (cons arc res))
               )
             )
             (setq points (cdr points)
                   start end)
             )
           )
         )
       )
     )
    res
  )
         
  (if
    (setq ss (ssget ":L" '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE,INSERT"))));added insert (Jef!)
    (progn
      (repeat (setq i (sslength ss));added by Jef!
        (setq i (1- i)
              e (ssname ss i)
              )
        (if (eq "INSERT" (cdr (assoc 0 (entget e))))
            (progn
              (dupfromins e nil)
              (ssdel e ss)
              )
          )
        
      );end added by Jef!
      (repeat (setq i (sslength ss))
        (setq i (1- i)
              e (ssname ss i)
              e (vlax-ename->vla-object e)
              )
        (if
          (eq (vla-get-ObjectName e) "AcDbPolyline")
          (foreach x (vlax-invoke e 'Explode)
            (setq lst (cons x lst))
            )
          (setq lst (cons (vla-copy e) lst))
        )
      )
      (if
        (setq segments
          (apply 'append
            (mapcar
              (function
                (lambda (e / l)
                  (break_object e
                    (progn
                      (foreach other (vl-remove e lst)
                        (foreach x (l2p (vlax-invoke e 'intersectwith other acExtendNone))
                           (setq l (cons x l))
                        )
                      )
                      (if
                        (eq (vla-get-ObjectName e) "AcDbCircle")
                        l
                        (cons (vlax-curve-getendpoint e) l)
                      )
                    )
                  )
                )
              )
              lst
            )
          )
        )
        (progn
          (setq reg (vlax-invoke ms 'AddRegion segments))
          (foreach x (append segments lst) (vla-delete x))
          (setvar 'peditaccept 1)
          (setvar 'draworderctl 0)
          (setvar 'cmdecho 0)
          (foreach x reg
            (setq x (vlax-vla-object->ename x))
            (command "_explode" x)
            (command "_pedit" "_m" "_p" "" "_j" "" "")
            (if (> (vlax-curve-getArea (entlast)) aa) (setq aa (vlax-curve-getArea (setq ea (entlast)))))
            )
          (if (> (length reg) 1) (entdel ea))
          (if duplst (mapcar 'entdel duplst));added by Jef!
          (setvar 'peditaccept pa)
          (setvar 'draworderctl dr)
          (setvar 'cmdecho ce)
        )
        (princ "\nValid region(s) not found")
      )
    )
  )
  (vla-endundomark acDoc)
  (princ)
)

Cheers!

There you go it’s 3:26am here and can’t help but open my pc to test your code . This is pretty decent mate! Ah forget about the price I’m really just a poor guy

Thanks again

August 29, 2018

Hello Jef,
that is a very useful code. Thank you!
I work a lot with Xline. Could you install them in the code?

Many Thanks
Martin

August 4, 2019

hey @Jef!. it’s been a while, hope all is good.. thank you for this great code! it works great however im facing problem and if i have overlapping lines. is there a way to you ignore overlapping and continue to produce closed polyline? thank you very much .

Edited August 4, 2019 by loudy000

August 5, 2019

BEST IS : 1. MAKE HATCH BY PICK INTERNAL POINT.

2. SELECT ALL HATCH AND RIGHT CLICK GENERATE BOUNDARY. AND DELETE ALL HATCH.

Sign In

Generate Boundary Line By Selecting Intersecting lines

Recommended Posts

Roy_043

Link to comment

Share on other sites

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

ronjonp

BIGAL

BIGAL

Posted Images

Jef!

Link to comment

Share on other sites

loudy000

Link to comment

Share on other sites

martinle

Link to comment

Share on other sites

loudy000

Link to comment

Share on other sites

Ish

Link to comment

Share on other sites

Join the conversation

ronjonp

BIGAL

BIGAL

Tutorials

Forums

Activity