TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ribarm on July 17, 2014, 09:35:11 AM

Title: split closed LWPOLY
Post by: ribarm on July 17, 2014, 09:35:11 AM
I want to achieve this... See attachments...

Thanks, M.R.

P.S. Resulting LWPOLYLINEs should have minimal number of vertices... For red LWPOLY => 8 vertices...
Title: Re: split closed LWPOLY
Post by: CAB on July 17, 2014, 10:18:35 AM
The easy way is to have the user select (ssget) sections to isolate.
Get the vertex which are within the selection \window.
Create the shape with the vertex.
Remove the vertex from the main object
Repeat selection.
Title: Re: split closed LWPOLY
Post by: ribarm on July 17, 2014, 10:34:14 AM
I don't understand... I have one LWPOLY for (ssget) and I want to split it into several like shown on picture... Can you post a picture with steps I should perform explaining your method CAB... Thanks...
Title: Re: split closed LWPOLY
Post by: LE3 on July 17, 2014, 11:14:01 AM
--- my first approach could be to glue all the lines that are collinear, based on a gap separation, then from there generate the closed boundaries.
Title: Re: split closed LWPOLY
Post by: CAB on July 17, 2014, 11:21:46 AM
I don't have time today to lend much help but ssnamex will return the coordinates the user used to pick the pline.
So use that info to get the vertex that fall within the selection rectangle.
It's been a long time ago that I used that feature but I may have some code to share. It will be later today.

Look at the help file for ssnamex
Quote
The data associated with an entity selected with the Window, WPolygon, Crossing, or CPolygon method is the integer ID of the polygon that selected the entity. It is up to the application to associate the polygon identifiers and make the connection between the polygon and the entities it selected. For example, the following returns an entity selected by Crossing (note that the polygon ID is –1): Command: (ssnamex ss4 0)
((3 <Entity name: 1d62d60> 0 -1) (-1 (0 (-1.80879 8.85536 0.0)) (0 (13.4004 8.85536 0.0)) (0 (13.4004 1.80024 0.0)) (0 (-1.80879 1.80024 0.0))))
Title: Re: split closed LWPOLY
Post by: LE3 on July 17, 2014, 12:58:17 PM
Quote from: LE on July 17, 2014, 11:14:01 AM
--- my first approach could be to glue all the lines that are collinear, based on a gap separation, then from there generate the closed boundaries.

had the chance to update my old gluelines arx command to run here on my a2014, and yes doing something similar will may work - see image below.
http://www.theswamp.org/index.php?topic=8646.msg110363#top

Title: Re: split closed LWPOLY
Post by: Lee Mac on July 17, 2014, 02:37:22 PM
The following is lazy & terrible coding, but should produce the desired result:

Code: [Select]
(defun c:test ( / sel )
    (if (setq sel (ssget "_+.:E:S:L" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
        (splitpoly (ssname sel 0))
    )
    (princ)
)
(defun splitpoly ( ent / *error* are col enx lin lst mxa mxp new nwp ply pnt reg tmp val var vec vtx )

    (defun *error* ( msg )
        (mapcar 'setvar var val)
        (LM:endundo (LM:acdoc))
        (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (LM:startundo (LM:acdoc))
    (setq col  0
          var '(cmdecho peditaccept)
          val  (mapcar 'getvar var)
          enx  (entget ent)
          vtx  (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
    )
    (mapcar 'setvar var '(0 1))
    (if (= 1 (logand 1 (cdr (assoc 70 enx))))
        (setq vtx (cons (last vtx) vtx))
    )
    (while (cadr vtx)
        (setq tmp (list (car vtx) (cadr vtx)))
        (foreach x (setq vtx (cdr vtx))
            (if (LM:collinear-p x (car tmp) (cadr tmp))
                (setq tmp (cons x tmp))
            )
        )
        (setq lst (cons tmp lst) tmp nil)
    )
    (foreach x lst
        (setq vec (mapcar '- (car x) (cadr x))
              lin
            (append lin
                (mapcar
                   '(lambda ( a b )
                        (vlax-ename->vla-object
                            (entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b)))
                        )
                    )
                    (setq x
                        (vl-sort x
                           '(lambda ( a b )
                                (<  (caddr (trans a ent vec))
                                    (caddr (trans b ent vec))
                                )
                            )
                        )
                    )
                    (cdr x)
                )
            )
        )
    )
    (foreach obj
        (setq reg
            (vlax-invoke
                (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
                'addregion lin
            )
        )
        (command "_.pedit" "_m")
        (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke obj 'explode)))
        (command "" "_j" "" "")
        (vla-delete obj)
        (setq ply (entlast)
              vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ply)))
              new (list (cadr vtx) (car vtx))
              vtx (cddr vtx)
        )
        (while (setq pnt (car vtx))
            (setq vtx (cdr vtx))
            (if (LM:collinear-p pnt (car new) (cadr new))
                (setq new (cons pnt (cdr new)))
                (setq new (cons pnt new))
            )
        )
        (setq new (reverse new))
        (while (LM:collinear-p (car new) (cadr new) (last new))
            (setq new (cdr new))
        )
        (setq nwp
            (entmakex
                (append
                    (list
                       '(000 . "LWPOLYLINE")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbPolyline")
                        (cons 90 (length new))
                       '(070 . 1)
                        (cons 62 (setq col (1+ col)))
                    )
                    (mapcar '(lambda ( p ) (cons 10 p)) new)
                )
            )
        )
        (if (< mxa (setq are (vla-get-area (vlax-ename->vla-object ply))))
            (setq mxa are
                  mxp nwp
            )
        )
        (entdel ply)
    )
    (foreach l lin (vla-delete l))
    (entdel ent)
    (entdel mxp)
    (*error* nil)
    (princ)
)

;; Collinear-p  -  Lee Mac
;; Returns T if p1,p2,p3 are collinear

(defun LM:Collinear-p ( p1 p2 p3 )
    (   (lambda ( a b c )
            (or
                (equal (+ a b) c 1e-3)
                (equal (+ b c) a 1e-3)
                (equal (+ c a) b 1e-3)
            )
        )
        (distance p1 p2) (distance p2 p3) (distance p1 p3)
    )
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

(vl-load-com) (princ)
Title: Re: split closed LWPOLY
Post by: LE3 on July 17, 2014, 02:46:44 PM
^
just tried your routine Lee and getting (A2014):
Command: TEST
Select objects:
Error: bad function: #<USUBR @00000000340ffac0 -lambda->; reset after error

breaks here:
Quote
(vl-sort x
                            (lambda ( a b )
                                (<  (caddr (trans a ent vec))
                                    (caddr (trans b ent vec))
                                )
                            )
                        )

can't do more - I lost my lsp powers many moons ago.... :-(
Title: Re: split closed LWPOLY
Post by: Lee Mac on July 17, 2014, 02:47:53 PM
Quote from: LE on July 17, 2014, 02:46:44 PM
^
just tried your routine Lee and getting (A2014):
Command: TEST
Select objects:
Error: bad function: #<USUBR @00000000340ffac0 -lambda->; reset after error

breaks here:
Quote
(vl-sort x
                            (lambda ( a b )
                                (<  (caddr (trans a ent vec))
                                    (caddr (trans b ent vec))
                                )
                            )
                        )

can't do more - I lost my lsp powers many moons ago.... :-(

Oops! Forgot to quote the lambda function - code updated above - there could be more bugs, as the code was written very quickly!

Thanks Luis :)
Title: Re: split closed LWPOLY
Post by: LE3 on July 17, 2014, 02:52:24 PM
yep --- has some more (appears to) --- :)
Quote
Command: TEST
Select objects:
Yes or No, please.
; quit after error
Convert Lines, Arcs and Splines to polylines [Yes/No]? <Y> *Cancel*
Select polyline or [Multiple]: *Cancel*
Command: *Cancel*

breaks here:
Quote
(command "_.pedit" "_m")
        (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke obj 'explode)))
        (command "" "_j" "" "") ;;; <<== this line

But I see that does the job --- Good!
Title: Re: split closed LWPOLY
Post by: Lee Mac on July 17, 2014, 04:17:54 PM
Quote from: LE on July 17, 2014, 02:52:24 PM
yep --- has some more (appears to) --- :)
Quote
Command: TEST
Select objects:
Yes or No, please.
; quit after error
Convert Lines, Arcs and Splines to polylines [Yes/No]? <Y> *Cancel*
Select polyline or [Multiple]: *Cancel*
Command: *Cancel*

breaks here:
Quote
(command "_.pedit" "_m")
        (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke obj 'explode)))
        (command "" "_j" "" "") ;;; <<== this line

Ah yes - I had overlooked PEDITACCEPT - I should really test my code more before posting  :oops:
I have updated the above code again.

Quote from: LE on July 17, 2014, 02:52:24 PM
But I see that does the job --- Good!

Thanks Luis, I appreciate you taking the time to test it :)
Title: Re: split closed LWPOLY
Post by: ribarm on July 17, 2014, 05:05:20 PM
I've found my version using my library, but it won't work on A2008 - last overkill command... It works on A2012, A2014...

Code: [Select]
(defun c:lins2lws ( / plintav-ss big ent i li livlalst ms pea pl qaf reg s ss tmp tot )

  (defun plintav-ss ( ss / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz add_vtx
                           sslpl sshpl i ent n ent1 ss-ent1 k ent2 intpts intptsall pl plpts restintpts par )

    (vl-load-com)

    (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
      (if (eq (type obj1) 'ENAME) (setq obj1 (vlax-ename->vla-object obj1)))
      (if (eq (type obj2) 'ENAME) (setq obj2 (vlax-ename->vla-object obj2)))
      (setq coords (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith obj1 obj2 AcExtendNone))))))
      (if (vl-catch-all-error-p coords)
        (setq ptlst nil)
        (repeat (/ (length coords) 3)
          (setq pt (list (car coords) (cadr coords) (caddr coords)))
          (setq ptlst (cons pt ptlst))
          (setq coords (cdddr coords))
        )
      )
      ptlst
    ) 

    (defun LM:Unique ( lst )
      (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
    )

    (defun AT:GetVertices ( e / p l )
      (LM:Unique
        (if e
          (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
            (repeat (setq p (1+ (fix p)))
              (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
            )
            (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
          )
        )
      )
    )

    (defun _reml ( l1 l2 / a n ls )
      (while
        (setq n nil
              a (car l2)
        )
        (while (and l1 (null n))
          (if (equal a (car l1) 1e-8)
            (setq l1 (cdr l1)
                  n t
            )
            (setq ls (append ls (list (car l1)))
                  l1 (cdr l1)
            )
          )
        )
        (setq l2 (cdr l2))
      )
      (append ls l1)
    )

    (defun member-fuzz ( expr lst fuzz )
      (while (and lst (not (equal (car lst) expr fuzz)))
        (setq lst (cdr lst))
      )
      lst
    )

    (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
        (vla-GetWidth obj (fix add_pt) 'sw 'ew)
        (vla-addVertex
            obj
            (1+ (fix add_pt))
            (vlax-make-variant
                (vlax-safearray-fill
                    (vlax-make-safearray vlax-vbdouble (cons 0 1))
                        (list
                            (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                            (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                        )
                )
            )
        )
        (setq bulg (vla-GetBulge obj (fix add_pt)))
        (vla-SetBulge obj
            (fix add_pt)
            (/
                (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
                (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
            )
        )
        (vla-SetBulge obj
            (1+ (fix add_pt))
            (/
                (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
                (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
            )
        )
        (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
        (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
        (vla-update obj)
    )

    (setq sslpl (ssadd) sshpl (ssadd))
    (setq i -1)
    (while (setq ent (ssname ss (setq i (1+ i))))
      (if (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
        (progn
          (entupd ent)
          (vla-update (vlax-ename->vla-object ent))
          (ssadd ent sslpl)
        )
      )
      (if (eq (cdr (assoc 0 (entget ent))) "POLYLINE")
        (ssadd ent sshpl)
      )
    )
    (setq i -1)
    (while (setq ent (ssname sshpl (setq i (1+ i))))
      (command "_.convertpoly" "l" ent "")
      (entupd ent)
      (vla-update (vlax-ename->vla-object ent))
      (ssadd ent sslpl)
    )
    (repeat (setq n (sslength ss))
      (setq ent1 (ssname ss (setq n (1- n))))
      (setq ss-ent1 (ssdel ent1 ss))
      (repeat (setq k (sslength ss-ent1))
        (setq ent2 (ssname ss-ent1 (setq k (1- k))))
        (setq intpts (intersobj1obj2 ent1 ent2))
        (setq intptsall (append intpts intptsall))
      )
    )
    (setq i -1)
    (while (setq pl (ssname sslpl (setq i (1+ i))))
      (setq plpts (AT:GetVertices pl))
      (setq restintpts (_reml intptsall plpts))
      (foreach pt restintpts
        (if
          (and
            (not (member-fuzz pt plpts 1e-6))
            (setq par (vlax-curve-getparamatpoint pl pt))
          )
          (add_vtx (vlax-ename->vla-object pl) par pl)       
        )
      )
    )
    (setq i -1)
    (while (setq ent (ssname sshpl (setq i (1+ i))))
      (command "_.convertpoly" "h" ent "")
    )
    (princ)
  )

  (vl-load-com)
  (setq ms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))

  (setq tot 0.0)
  (setq pea (getvar 'peditaccept))
  (setq qaf (getvar 'qaflags))
  (setvar 'peditaccept 1)
  (setvar 'qaflags 1)
  (setq ss (ssget "_X" '((0 . "LINE") (8 . "NEW"))))
  (command "_.pedit" "_m" ss)
  (while (> (getvar 'cmdactive) 0) (command ""))
  (setq ss (ssget "_X" '((0 . "LWPOLYLINE") (8 . "NEW"))))
  (plintav-ss ss)
  (setq ss (ssget "_X" '((0 . "LWPOLYLINE") (8 . "NEW"))))
  (command "_.explode" ss)
  (while (> (getvar 'cmdactive) 0) (command ""))
  (setq ss (ssget "_P"))
  (setq i -1)
  (while (setq li (ssname ss (setq i (1+ i))))
    (setq livlalst (cons (vlax-ename->vla-object li) livlalst))
  )
  (setq reg (vlax-invoke ms 'AddRegion livlalst))
  (foreach r reg
    (setq ent (entlast))
    (command "_.pedit" "_m")
    (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke r 'explode)))
    (command "" "_j" "" "")
    (if
      (and
        (not (eq ent (setq ent (entlast))))
        (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
      )
      (progn
        (setq tmp (vlax-curve-getarea ent)
              tot (+ tot tmp)
        )
        (if (< (car big) tmp)
          (setq big (list tmp ent))
        )
      )
    )
    (vla-delete r)
  )
  (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
    (entdel (cadr big))
  )
  (foreach obj livlalst (vla-delete obj))
  (setq ss (ssget "_X" '((0 . "LWPOLYLINE") (8 . "NEW"))))
  (setq i -1)
  (while (setq pl (ssname ss (setq i (1+ i))))
    (command "_.explode" pl)
    (while (> (getvar 'cmdactive) 0) (command ""))
    (setq s (ssget "_P"))
    (command "-overkill" "_p")
    (while (> (getvar 'cmdactive) 0) (command ""))
    (command "_.pedit" "_m" "_p" "" "_j" "" "")
    (entmod (subst (cons 8 lay) (assoc 8 (entget (entlast))) (entget (entlast))))
  )
  (setvar 'clayer lay)
  (command "_.-purge" "_LA" "NEW" "_N")
  (while (> (getvar 'cmdactive) 0) (command ""))
  (setvar 'peditaccept pea)
  (setvar 'qaflags qaf)
  (setq lay nil)
  (princ)
)

(defun c:splitlw ( / *error* a ent i k pl ss v vl vv )

  (vl-load-com)

  (defun *error* ( msg )
    (if msg (prompt msg))
    (princ)
  )

;;;----------------------------------- main routine -----------------------------------;;;
 
  (command "_.undo" "_BE")

  (setq pl (car (entsel "\nPick closed LWPOLYLINE polygon in WCS...")))
  (setq lay (cdr (assoc 8 (entget pl))))
  (if (not (tblsearch "LAYER" "NEW"))
    (progn
      (command "_.layer" "_m" "NEW")
      (while (> (getvar 'cmdactive) 0) (command ""))
    )
    (progn
      (alert "Purge layer \"NEW\" which is used in this routine and restart routine again - quitting...")
      (exit)
    )
  )
  (entmod (subst (cons 8 "NEW") (assoc 8 (entget pl)) (entget pl)))
  (setq vl (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 10)) (entget pl))))
  (if (not (equal (car vl) (last vl) 1e-6)) (setq vl (reverse (cons (car vl) (reverse vl)))))
  (setq k -1)
  (foreach p1 (setq v (append vl (cdr vl)))
    (setq vv (append vl (cdr vl)))
    (setq k (1+ k))
    (if (nth (1+ k) vv) (setq a (angle p1 (nth (1+ k) vv))))
    (foreach p2 (repeat (1+ k) (setq vv (cdr vv)))
      (if (equal a (angle p1 p2) 1e-6)
        (entmake (list '(0 . "LINE") (cons 8 "NEW") (cons 10 p1) (cons 11 p2)))
      )
    )
  )
  (command "_.explode" pl)
  (while (> (getvar 'cmdactive) 0) (command ""))
  (setq ss (ssget "_X" '((0 . "LINE") (8 . "NEW"))))
  (setq i -1)
  (while (setq ent (ssname ss (setq i (1+ i))))
    (if (equal (cdr (assoc 10 (entget ent))) (cdr (assoc 11 (entget ent))) 1e-6)
      (entdel ent)
    )
  )
  (setq ss (ssget "_X" '((0 . "LINE") (8 . "NEW"))))
  (command "_.select" ss)
  (while (> (getvar 'cmdactive) 0) (command ""))
  (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) "-overkill\np\n\n\n")
  (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) "(c:lins2lws)\n")
  (alert "For \"UNDO\" - type \"UNDO\" \"B\"")
  (princ)
)

Thanks for all reply...
Title: Re: split closed LWPOLY
Post by: ribarm on July 18, 2014, 03:19:50 AM
After numerous modifications, I am finally satisfied with above posted code... Although it won't work correctly with lower versions of ACAD, it works as desired on A2012, A2014... Now you can copy the code and if you find it useful than the goal is achieved... I need it for separating areas on which I can do various things among else is also projecting functions and if necessary find roof solutions...

M.R. (arch.)
Thanks again... :-)
Title: Re: split closed LWPOLY
Post by: ribarm on August 02, 2014, 05:11:55 AM
After my little vacation, I've updated code to work and on lower versions of ACADs... Hope CAB will be satisfied... Of course many thanks to Lee Mac as I applied his part of code - still had to little modify it... Look in code and you'll see that I've added one line for checking collinear-p for first, last and vertex before last one... Hope it will do correctly in all cases, if not please inform me...

Kind regards, M.R.

Code - Auto/Visual Lisp: [Select]
  1. (defun c:splitlw ( / *error* LM:Collinear-p lininlin-p plintav-ss a big cmd d ent entlst i k li lilst linew linsnew livlalst ms new pea pl pnt qaf reg s ss tmp tot vl vtx vv )
  2.  
  4.  
  5.   (defun *error* ( msg )
  6.     (if cmd (setvar 'cmdecho cmd))
  7.     (if pea (setvar 'peditaccept pea))
  8.     (if qaf (setvar 'qaflags qaf))
  10.     (if msg (prompt msg))
  11.     (princ)
  12.   )
  13.  
  14.   ;; Collinear-p  -  Lee Mac
  15.   ;; Returns T if p1,p2,p3 are collinear
  16.  
  17.   (defun LM:Collinear-p ( p1 p2 p3 )
  18.     ( (lambda ( a b c )
  19.         (or
  20.           (equal (+ a b) c 1e-3)
  21.           (equal (+ b c) a 1e-3)
  22.           (equal (+ c a) b 1e-3)
  23.         )
  24.       )
  25.       (distance p1 p2) (distance p2 p3) (distance p1 p3)
  26.     )
  27.   )
  28.  
  29.   (defun lininlin-p ( lin linlst )
  30.     (vl-some '(lambda ( x ) (and (or
  31.                                    (not (equal (car x) (car lin) 1e-6))
  32.                                    (not (equal (cadr x) (cadr lin) 1e-6))
  33.                                  )
  34.                                  (equal (distance (car x) (cadr x)) (+ (distance (car x) (car lin)) (distance (cadr x) (car lin))) 1e-6)
  35.                                  (equal (distance (car x) (cadr x)) (+ (distance (car x) (cadr lin)) (distance (cadr x) (cadr lin))) 1e-6)
  36.                             )
  37.               ) linlst
  38.     )
  39.   )
  40.  
  41.   (defun plintav-ss ( ss / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz add_vtx
  42.                            sslpl sshpl i ent n ent1 ss-ent1 k ent2 intpts intptsall pl plpts restintpts par )
  43.  
  44.     (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
  45.       (if (eq (type obj1) 'ENAME) (setq obj1 (vlax-ename->vla-object obj1)))
  46.       (if (eq (type obj2) 'ENAME) (setq obj2 (vlax-ename->vla-object obj2)))
  47.       (setq coords (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith obj1 obj2 AcExtendNone))))))
  48.       (if (vl-catch-all-error-p coords)
  49.         (setq ptlst nil)
  50.         (repeat (/ (length coords) 3)
  51.           (setq pt (list (car coords) (cadr coords) (caddr coords)))
  52.           (setq ptlst (cons pt ptlst))
  53.           (setq coords (cdddr coords))
  54.         )
  55.       )
  56.       ptlst
  57.     )  
  58.  
  59.     (defun LM:Unique ( lst )
  60.       (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
  61.     )
  62.  
  63.     (defun AT:GetVertices ( e / p l )
  64.       (LM:Unique
  65.         (if e
  66.           (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
  67.             (repeat (setq p (1+ (fix p)))
  68.               (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
  69.             )
  71.           )
  72.         )
  73.       )
  74.     )
  75.  
  76.     (defun _reml ( l1 l2 / a n ls )
  77.       (while
  78.         (setq n nil
  79.               a (car l2)
  80.         )
  81.         (while (and l1 (null n))
  82.           (if (equal a (car l1) 1e-8)
  83.             (setq l1 (cdr l1)
  84.                   n t
  85.             )
  86.             (setq ls (append ls (list (car l1)))
  87.                   l1 (cdr l1)
  88.             )
  89.           )
  90.         )
  91.         (setq l2 (cdr l2))
  92.       )
  93.       (append ls l1)
  94.     )
  95.  
  96.     (defun member-fuzz ( expr lst fuzz )
  97.       (while (and lst (not (equal (car lst) expr fuzz)))
  98.         (setq lst (cdr lst))
  99.       )
  100.       lst
  101.     )
  102.  
  103.     (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
  104.         (vla-GetWidth obj (fix add_pt) 'sw 'ew)
  105.         (vla-addVertex
  106.             obj
  107.             (1+ (fix add_pt))
  108.             (vlax-make-variant
  109.                 (vlax-safearray-fill
  110.                     (vlax-make-safearray vlax-vbdouble (cons 0 1))
  111.                         (list
  112.                             (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
  113.                             (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
  114.                         )
  115.                 )
  116.             )
  117.         )
  118.         (setq bulg (vla-GetBulge obj (fix add_pt)))
  119.         (vla-SetBulge obj
  120.             (fix add_pt)
  121.             (/
  122.                 (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
  123.                 (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
  124.             )
  125.         )
  126.         (vla-SetBulge obj
  127.             (1+ (fix add_pt))
  128.             (/
  129.                 (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
  130.                 (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
  131.             )
  132.         )
  133.         (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
  134.         (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
  135.         (vla-update obj)
  136.     )
  137.  
  138.     (setq sslpl (ssadd) sshpl (ssadd))
  139.     (setq i -1)
  140.     (while (setq ent (ssname ss (setq i (1+ i))))
  141.       (if (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
  142.         (progn
  143.           (entupd ent)
  144.           (vla-update (vlax-ename->vla-object ent))
  145.           (ssadd ent sslpl)
  146.         )
  147.       )
  148.       (if (eq (cdr (assoc 0 (entget ent))) "POLYLINE")
  149.         (ssadd ent sshpl)
  150.       )
  151.     )
  152.     (setq i -1)
  153.     (while (setq ent (ssname sshpl (setq i (1+ i))))
  154.       (command "_.convertpoly" "l" ent "")
  155.       (entupd ent)
  156.       (vla-update (vlax-ename->vla-object ent))
  157.       (ssadd ent sslpl)
  158.     )
  159.     (repeat (setq n (sslength ss))
  160.       (setq ent1 (ssname ss (setq n (1- n))))
  161.       (setq ss-ent1 (ssdel ent1 ss))
  162.       (repeat (setq k (sslength ss-ent1))
  163.         (setq ent2 (ssname ss-ent1 (setq k (1- k))))
  164.         (setq intpts (intersobj1obj2 ent1 ent2))
  165.         (setq intptsall (append intpts intptsall))
  166.       )
  167.     )
  168.     (setq i -1)
  169.     (while (setq pl (ssname sslpl (setq i (1+ i))))
  170.       (setq plpts (AT:GetVertices pl))
  171.       (setq restintpts (_reml intptsall plpts))
  172.       (foreach pt restintpts
  173.         (if
  174.           (and
  175.             (not (member-fuzz pt plpts 1e-6))
  176.             (setq par (vlax-curve-getparamatpoint pl pt))
  177.           )
  178.           (add_vtx (vlax-ename->vla-object pl) par pl)        
  179.         )
  180.       )
  181.     )
  182.     (setq i -1)
  183.     (while (setq ent (ssname sshpl (setq i (1+ i))))
  184.       (command "_.convertpoly" "h" ent "")
  185.     )
  186.     (if sslpl sslpl sshpl)
  187.   )
  188.  
  189. ;;;----------------------------------- main routine -----------------------------------;;;
  190.  
  193.  
  194.   (setq tot 0.0)
  195.   (setq cmd (getvar 'cmdecho))
  196.   (setq pea (getvar 'peditaccept))
  197.   (setq qaf (getvar 'qaflags))
  198.   (setvar 'cmdecho 0)
  199.   (setvar 'peditaccept 1)
  200.   (setvar 'qaflags 1)
  201.   (setq pl (car (entsel "\nPick closed LWPOLYLINE polygon in WCS...")))
  202.   (setq vl (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 10)) (entget pl))))
  203.   (if (not (equal (car vl) (last vl) 1e-6)) (setq vl (reverse (cons (car vl) (reverse vl)))))
  204.   (setq k -1)
  205.   (foreach p1 (append vl (cdr vl))
  206.     (setq vv (append vl (cdr vl)))
  207.     (setq k (1+ k))
  208.     (if (nth (1+ k) vv) (setq a (angle p1 (nth (1+ k) vv))))
  209.     (foreach p2 (repeat (1+ k) (setq vv (cdr vv)))
  210.       (if (equal a (angle p1 p2) 1e-6)
  211.         (progn
  212.           (setq li (list p1 p2))
  213.           (setq lilst (cons li lilst))
  214.         )
  215.       )
  216.     )
  217.   )
  218.   (command "_.explode" pl)
  219.   (while (> (getvar 'cmdactive) 0) (command ""))
  220.   (setq ss (ssget "_P"))
  221.   (setq i -1)
  222.   (while (setq ent (ssname ss (setq i (1+ i))))
  223.     (progn
  224.       (setq lilst (cons (list (cdr (assoc 10 (entget ent))) (cdr (assoc 11 (entget ent)))) lilst))
  225.       (setq entlst (cons ent entlst))
  226.     )
  227.   )
  228.   (foreach li lilst
  229.     (if (equal (car li) (cadr li) 1e-6)
  230.       (setq lilst (vl-remove li lilst))
  231.     )
  232.   )
  233.   (foreach lin1 lilst
  234.     (setq a (angle (car lin1) (cadr lin1)))
  235.     (setq d (distance (car lin1) (cadr lin1)))
  236.     (foreach lin2 (vl-remove lin1 lilst)
  237.       (if (and
  238.             (equal a (angle (car lin1) (cadr lin2)) 1e-6)
  239.             (< d (setq d (distance (car lin1) (cadr lin2))))
  240.           )
  241.           (if linew
  242.             (setq linew (subst (cadr linew) (cadr lin2) linew))
  243.             (setq linew (list (car lin1) (cadr lin2)))
  244.           )
  245.       )
  246.     )
  247.     (if (and linew (not (member linew linsnew)))
  248.       (setq linsnew (cons linew linsnew))
  249.     )
  250.     (if (and (not linew) (not (member (list (car lin1) (cadr lin1)) linsnew)))
  251.       (setq linsnew (cons (list (car lin1) (cadr lin1)) linsnew))
  252.     )
  253.     (setq linew nil)
  254.   )
  255.   (foreach lin linsnew
  256.     (if (lininlin-p lin linsnew)
  257.       (setq linsnew (vl-remove lin linsnew))
  258.     )
  259.   )
  260.   (foreach ent entlst
  261.     (entdel ent)
  262.   )
  263.   (setq ss (ssadd))
  264.   (foreach linew linsnew
  265.     (setq li (entmakex (list '(0 . "LINE") (cons 10 (car linew)) (cons 11 (cadr linew)))))
  266.     (ssadd li ss)
  267.   )
  268.   (setq s (ssadd))
  269.   (setq i -1)
  270.   (while (setq li (ssname ss (setq i (1+ i))))
  271.     (command "_.pedit" li)
  272.     (while (> (getvar 'cmdactive) 0) (command ""))
  273.     (ssadd (entlast) s)
  274.   )
  275.   (setq ss (plintav-ss s))
  276.   (command "_.explode" ss)
  277.   (while (> (getvar 'cmdactive) 0) (command ""))
  278.   (setq ss (ssget "_P"))
  279.   (setq i -1)
  280.   (while (setq li (ssname ss (setq i (1+ i))))
  281.     (setq livlalst (cons (vlax-ename->vla-object li) livlalst))
  282.   )
  283.   (setq reg (vlax-invoke ms 'AddRegion livlalst))
  284.   (setq ss (ssadd))
  285.   (foreach r reg
  286.     (setq ent (entlast))
  287.     (command "_.pedit" "_m")
  288.     (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke r 'explode)))
  289.     (command "" "_j" "" "")
  290.     (if
  291.       (and
  292.         (not (eq ent (setq ent (entlast))))
  293.         (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
  294.       )
  295.       (progn
  296.         (setq tmp (vlax-curve-getarea ent)
  297.               tot (+ tot tmp)
  298.         )
  299.         (if (< (car big) tmp)
  300.           (setq big (list tmp ent))
  301.         )
  302.         (ssadd ent ss)
  303.       )
  304.     )
  305.     (vla-delete r)
  306.   )
  307.   (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
  308.     (progn
  309.       (ssdel (cadr big) ss)
  310.       (entdel (cadr big))
  311.     )
  312.   )
  313.   (foreach obj livlalst (vla-delete obj))
  314.   (setq i -1)
  315.   (while (setq pl (ssname ss (setq i (1+ i))))
  316.     (setq vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl)))
  317.           new (list (cadr vtx) (car vtx))
  318.           vtx (cddr vtx)
  319.     )
  320.     (while (setq pnt (car vtx))
  321.       (setq vtx (cdr vtx))
  322.       (if (LM:collinear-p pnt (car new) (cadr new))
  323.         (setq new (cons pnt (cdr new)))
  324.         (setq new (cons pnt new))
  325.       )
  326.     )
  327.     (setq new (reverse new))
  328.     (while (LM:collinear-p (car new) (cadr new) (last new))
  329.       (setq new (cdr new))
  330.     )
  331.     (while (LM:collinear-p (cadr (reverse new)) (last new) (car new))
  332.       (setq new (reverse (cdr (reverse new))))
  333.     )
  334.     (entmake
  335.       (append
  336.         (list
  337.          '(000 . "LWPOLYLINE")
  338.          '(100 . "AcDbEntity")
  339.          '(100 . "AcDbPolyline")
  340.           (cons 90 (length new))
  341.          '(070 . 1)
  342.         )
  343.         (mapcar '(lambda ( p ) (cons 10 p)) new)
  344.       )
  345.     )
  346.     (entdel pl)
  347.   )
  348.   (*error* nil)
  349. )
  350.  
Title: Re: split closed LWPOLY
Post by: CAB on August 02, 2014, 10:22:48 AM
Nice job, works in ACAD2006  :)
Title: Re: split closed LWPOLY
Post by: ribarm on February 11, 2015, 10:24:05 AM
I know this is now old topic, but in addition to this issue, I've realized that there may be more general solution not only with orthogonal polygons, but with any type of polygonal LWPOLYLINE... So I am posting here my latest code in order to help if someone find it useful... Note, sometimes it may work correctly, but sometimes with too complex polyline it may fail to convert to split polylines... Also, you need to have loaded plintav.lsp from PLINETOOLS posted here (http://www.cadtutor.net/forum/showthread.php?67924-Draw-polyline-along-with-2-or-more-adjacent-closed-polylines/page3&p=#25)... Also worth of mention is this topic with Evgeniy's code for quadrilaterals...
http://www.theswamp.org/index.php?topic=44590.msg498376#msg498376

Code - Auto/Visual Lisp: [Select]
  1. (defun c:splitcllw-boundaryextensions ( / *error* unique colinear-p vk_IsPointInside add_vtx purge-pline BulgeData tan ms *adoc* tot cmd pea qaf reg ent tmp big ss pl i li vtxlst ptlstn lilst linlst linlstt plinlst livlalst p plst pplst )
  2.  
  3.   (defun *error* ( msg )
  4.     (if cmd (setvar 'cmdecho cmd))
  5.     (if pea (setvar 'peditaccept pea))
  6.     (if qaf (setvar 'qaflags qaf))
  7.     (vla-endundomark *adoc*)
  8.     (if msg (prompt msg))
  9.     (princ)
  10.   )
  11.  
  12.   (defun unique ( l )
  13.     (if l (cons (car l) (vl-remove-if '(lambda ( x ) (equal (car l) x 1e-6)) (unique (cdr l)))))
  14.   )
  15.  
  16.   (defun colinear-p ( p1 p2 p3 )
  17.     (equal (+ (distance p1 p2) (distance p2 p3)) (distance p1 p3) 1e-6)
  18.   )
  19.  
  20.   (defun vk_IsPointInside ( Point PointsList / PY P1Y P2Y )
  21.   ; works with polygons only, i.e. if (equal (car PointsList) (last PointsList))
  22.     (if (cdr PointsList)
  23.       (/=       (and (or (and (<= (setq PY  (cadr Point)
  24.                                   P2Y (cadadr PointsList)
  25.                                   P1Y (cadar PointsList)
  26.                             )
  27.                             PY
  28.                         )
  29.                         (< PY P2Y)
  30.                     )
  31.                     (and (> P1Y PY) (>= PY P2Y))
  32.                 )
  33.                 (> (car Point)
  34.                     (+ (* (/ (- PY P1Y) (- P2Y P1Y))
  35.                           (- (caadr PointsList) (caar PointsList))
  36.                        )
  37.                        (caar PointsList)
  38.                     )
  39.                 )
  40.           )
  41.           (vk_IsPointInside Point (cdr PointsList))
  42.       )
  43.     )
  44.   )
  45.  
  46.   (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
  47.       (vla-GetWidth obj (fix add_pt) 'sw 'ew)
  48.       (vla-addVertex
  49.           obj
  50.           (1+ (fix add_pt))
  51.           (vlax-make-variant
  52.               (vlax-safearray-fill
  53.                   (vlax-make-safearray vlax-vbdouble (cons 0 1))
  54.                       (list
  55.                           (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
  56.                           (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
  57.                       )
  58.               )
  59.           )
  60.       )
  61.       (setq bulg (vla-GetBulge obj (fix add_pt)))
  62.       (vla-SetBulge obj
  63.           (fix add_pt)
  64.           (/
  65.               (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
  66.               (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
  67.           )
  68.       )
  69.       (vla-SetBulge obj
  70.           (1+ (fix add_pt))
  71.           (/
  72.               (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
  73.               (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
  74.           )
  75.       )
  76.       (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
  77.       (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
  78.       (vla-update obj)
  79.   )
  80.  
  81.   ;; Purge-Pline (gile) 2007/11/25
  82.   ;;
  83.   ;; Removes all superfluous vertex (overwritten, colinear or concentric)
  84.   ;; Keeps arcs and widths
  85.   ;; Keeps aligne vertices which show a width break
  86.   ;; Closes pline which start point and end point are overwritten
  87.  
  88.   (defun purge-pline (pl        /         regular-width       colinear
  89.                       concentric          del-cadr  pour-car  elst
  90.                       closed    old-p     old-b     old-sw    old-ew
  91.                       new-d     new-p     new-b     new-sw    new-ew
  92.                       b1        b2
  93.                      )
  94.  
  95.     ;; Evaluates if the pline width is regular on 3 successive points
  96.     (defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta)
  97.       (or (= ws1 we1 ws2 we2)
  98.           (and (= we1 ws2)
  99.                (/= 0 (setq delta (- we2 ws1)))
  100.                (equal (/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0))
  101.                             (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
  102.                          )
  103.                          (- (vlax-curve-getDistAtPoint pl (trans p3 pl 0))
  104.                             (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
  105.                          )
  106.                       )
  107.                       (/ (- we1 (- we2 delta)) delta)
  108.                       1e-9
  109.                )
  110.           )
  111.       )
  112.     )
  113.  
  114.     ;; Evaluates if 3 successive vertices are aligned
  115.     (defun colinear (p1 p2 p3 b1 b2)
  116.       (and (zerop b1)
  117.            (zerop b2)
  118.            (null (inters p1 p2 p1 p3)
  119.            )
  120.       )
  121.     )
  122.  
  123.     ;; Evaluates if 3 sucessive vertices have the same center
  124.     (defun concentric (p1 p2 p3 b1 b2 / bd1 bd2)
  125.       (if
  126.         (and (/= 0.0 b1)
  127.              (/= 0.0 b2)
  128.              (equal
  129.                (caddr (setq bd1 (BulgeData b1 p1 p2)))
  130.                (caddr (setq bd2 (BulgeData b2 p2 p3)))
  131.                1e-9
  132.              )
  133.         )
  134.          (tan (/ (+ (car bd1) (car bd2)) 4.0))
  135.       )
  136.     )
  137.  
  138.     ;; Removes the second item of the list
  139.     (defun del-cadr (lst)
  140.       (set lst (cons (car (eval lst)) (cddr (eval lst))))
  141.     )
  142.  
  143.     ;; Pours the first item of a list to another one
  144.     (defun pour-car (from to)
  145.       (set to (cons (car (eval from)) (eval to)))
  146.       (set from (cdr (eval from)))
  147.     )
  148.  
  149.  
  150.     (setq elst (entget pl))
  151.     (and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
  152.     (mapcar (function (lambda (x)
  153.                         (cond
  154.                           ((= (car x) 10) (setq old-p (cons x old-p)))
  155.                           ((= (car x) 40) (setq old-sw (cons x old-sw)))
  156.                           ((= (car x) 41) (setq old-ew (cons x old-ew)))
  157.                           ((= (car x) 42) (setq old-b (cons x old-b)))
  158.                           (T (setq new-d (cons x new-d)))
  159.                         )
  160.                       )
  161.             )
  162.             elst
  163.     )
  164.     (mapcar (function (lambda (l)
  165.                         (set l (reverse (eval l)))
  166.                       )
  167.             )
  168.             '(old-p old-sw old-ew old-b new-d)
  169.     )
  170.     (and closed (setq old-p (append old-p (list (car old-p)))))
  171.     (and (equal (cdar old-p) (cdr (last old-p)) 1e-9)
  172.          (setq closed T
  173.                new-d  (subst (cons 70 (Boole 7 (cdr (assoc 70 new-d)) 1))
  174.                              (assoc 70 new-d)
  175.                              new-d
  176.                       )
  177.          )
  178.     )
  179.     (while (cddr old-p)
  180.       (if (regular-width
  181.             (cdar old-p)
  182.             (cdadr old-p)
  183.             (cdaddr old-p)
  184.             (cdar old-sw)
  185.             (cdar old-ew)
  186.             (cdadr old-sw)
  187.             (cdadr old-ew)
  188.           )
  189.         (cond
  190.           ((colinear (cdar old-p)
  191.                      (cdadr old-p)
  192.                      (cdaddr old-p)
  193.                      (cdar old-b)
  194.                      (cdadr old-b)
  195.            )
  196.            (mapcar 'del-cadr '(old-p old-sw old-ew old-b))
  197.           )
  198.           ((setq bu (concentric
  199.                       (cdar old-p)
  200.                       (cdadr old-p)
  201.                       (cdaddr old-p)
  202.                       (cdar old-b)
  203.                       (cdadr old-b)
  204.                     )
  205.            )
  206.            (setq old-b (cons (cons 42 bu) (cddr old-b)))
  207.            (mapcar 'del-cadr '(old-p old-sw old-ew))
  208.           )
  209.           (T
  210.            (mapcar 'pour-car
  211.                    '(old-p old-sw old-ew old-b)
  212.                    '(new-p new-sw new-ew new-b)
  213.            )
  214.           )
  215.         )
  216.         (mapcar 'pour-car
  217.                 '(old-p old-sw old-ew old-b)
  218.                 '(new-p new-sw new-ew new-b)
  219.         )
  220.       )
  221.     )
  222.     (if closed
  223.       (setq new-p (reverse (cons (car old-p) new-p)))
  224.       (setq new-p (append (reverse new-p) old-p))
  225.     )
  226.     (mapcar
  227.       (function
  228.         (lambda (new old)
  229.           (set new (append (reverse (eval new)) (eval old)))
  230.         )
  231.       )
  232.       '(new-sw new-ew new-b)
  233.       '(old-sw old-ew old-b)
  234.     )
  235.     (if (and closed
  236.              (regular-width
  237.                (cdr (last new-p))
  238.                (cdar new-p)
  239.                (cdadr new-p)
  240.                (cdr (last new-sw))
  241.                (cdr (last new-ew))
  242.                (cdar new-sw)
  243.                (cdar new-ew)
  244.              )
  245.         )
  246.       (cond
  247.         ((colinear (cdr (last new-p))
  248.                    (cdar new-p)
  249.                    (cdadr new-p)
  250.                    (cdr (last new-b))
  251.                    (cdar new-b)
  252.          )
  253.          (mapcar (function (lambda (l)
  254.                              (set l (cdr (eval l)))
  255.                            )
  256.                  )
  257.                  '(new-p new-sw new-ew new-b)
  258.          )
  259.         )
  260.         ((setq bu (concentric
  261.                     (cdr (last new-p))
  262.                     (cdar new-p)
  263.                     (cdadr new-p)
  264.                     (cdr (last new-b))
  265.                     (cdar new-b)
  266.                   )
  267.          )
  268.          (setq new-b
  269.                 (cdr (reverse (cons (cons 42 bu) (cdr (reverse new-b)))))
  270.          )
  271.          (mapcar (function (lambda (l)
  272.                              (set l (cdr (eval l)))
  273.                            )
  274.                  )
  275.                  '(new-p new-sw new-ew)
  276.          )
  277.         )
  278.       )
  279.     )
  280.     (entmod
  281.       (append new-d
  282.               (apply 'append
  283.                      (apply 'mapcar
  284.                             (cons 'list (list new-p new-sw new-ew new-b))
  285.                      )
  286.               )
  287.       )
  288.     )
  289.   )
  290.  
  291.   ;; BulgeData Retourne les données d'un polyarc (angle rayon centre)
  292.  
  293.   (defun BulgeData (bu p1 p2 / ang rad cen)
  294.     (setq ang (* 2 (atan bu))
  295.           rad (/ (distance p1 p2)
  296.                  (* 2 (sin ang))
  297.               )
  298.           cen (polar p1
  299.                      (+ (angle p1 p2) (- (/ pi 2) ang))
  300.                      rad
  301.               )
  302.     )
  303.     (list (* ang 2.0) rad cen)
  304.   )
  305.  
  306.   ;; TAN Retourne la tangente de l'angle
  307.  
  308.   (defun tan (ang)
  309.     (/ (sin ang) (cos ang))
  310.   )
  311.  
  314.  
  315.   (vla-startundomark *adoc*)
  316.   (prompt "\nPick closed polygonal LWPOLYLINE...")
  317.   (setq ss (ssget "_+.:E:S:L" (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 1) '(70 . 129) '(-4 . "or>"))))
  318.   (while (not ss)
  319.     (prompt "\nEmpty sel.set... Pick closed polygonal LWPOLYLINE again...")
  320.     (setq ss (ssget "_+.:E:S:L" (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 1) '(70 . 129) '(-4 . "or>"))))
  321.   )
  322.   (setq pl (ssname ss 0))
  323.   (setq vtxlst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (eq (car x) 10)) (entget pl))))
  324.   (setq lilst (mapcar '(lambda ( a b ) (list a b)) (cons (last vtxlst) vtxlst) vtxlst))
  325.   (setq ptlstn (reverse (cons (car vtxlst) (reverse vtxlst))))
  326.   (foreach li1 lilst
  327.     (foreach li2 (vl-remove li1 lilst)
  328.       (if (setq p (inters (car li1) (cadr li1) (car li2) (cadr li2) nil))
  329.         (setq plst (cons p plst))
  330.       )
  331.     )
  332.   )
  333.   (setq plst (unique plst))
  334.   (foreach p plst
  336.       (setq pplst (cons p pplst))
  337.     )
  338.   )
  339.   (setq pplst (unique pplst))
  340.   (foreach p pplst
  341.     (add_vtx (vlax-ename->vla-object pl) (vlax-curve-getparamatpoint pl (vlax-curve-getclosestpointto pl p)) pl)
  342.   )
  343.   (foreach p pplst
  344.     (foreach li lilst
  345.       (cond
  346.         ( (colinear-p (car li) (cadr li) p)
  347.           (entmake (list '(0 . "LINE") (cons 10 (cadr li)) (cons 11 p)))
  348.           (if (or (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) 0.01) ptlstn))
  349.                   (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) ptlstn))
  350.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) 0.01))
  352.               )
  353.             (entdel (entlast))
  354.             (setq linlst (cons (entlast) linlst))
  355.           )
  356.         )
  357.         ( (colinear-p (cadr li) (car li) p)
  358.           (entmake (list '(0 . "LINE") (cons 10 (car li)) (cons 11 p)))
  359.           (if (or (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) 0.01) ptlstn))
  360.                   (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) ptlstn))
  361.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) 0.01))
  363.               )
  364.             (entdel (entlast))
  365.             (setq linlst (cons (entlast) linlst))
  366.           )
  367.         )
  368.         ( (colinear-p p (car li) (cadr li))
  369.           (entmake (list '(0 . "LINE") (cons 10 p) (cons 11 (car li))))
  370.           (if (or (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) 0.01) ptlstn))
  371.                   (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) ptlstn))
  372.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) 0.01))
  374.               )
  375.             (entdel (entlast))
  376.             (setq linlst (cons (entlast) linlst))
  377.           )
  378.         )
  379.         ( (colinear-p p (cadr li) (car li))
  380.           (entmake (list '(0 . "LINE") (cons 10 p) (cons 11 (cadr li))))
  381.           (if (or (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) 0.01) ptlstn))
  382.                   (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) ptlstn))
  383.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) 0.01))
  385.               )
  386.             (entdel (entlast))
  387.             (setq linlst (cons (entlast) linlst))
  388.           )
  389.         )
  390.       )
  391.     )
  392.   )
  393.   (setq tot 0.0)
  394.   (setq cmd (getvar 'cmdecho))
  395.   (setq pea (getvar 'peditaccept))
  396.   (setq qaf (getvar 'qaflags))
  397.   (setvar 'cmdecho 0)
  398.   (setvar 'peditaccept 1)
  399.   (setvar 'qaflags 1)
  400.   (command "_.EXPLODE" pl)
  401.   (while (> (getvar 'cmdactive) 0) (command ""))
  402.   (setq ss (ssget "_P"))
  403.   (repeat (setq i (sslength ss))
  404.     (setq li (ssname ss (setq i (1- i))))
  405.     (setq linlstt (cons li linlstt))
  406.   )
  407.   (foreach lin linlst
  408.     (command "_.PEDIT" lin "")
  409.     (while (> (getvar 'cmdactive) 0) (command ""))
  410.     (setq plinlst (cons (entlast) plinlst))
  411.   )
  412.   (setq ss (ssadd))
  413.   (foreach pll plinlst
  414.     (ssadd pll ss)
  415.   )
  416.   (if plinlst
  417.     (progn
  418.       (sssetfirst nil ss)
  419.       (c:plintav)
  420.       (command "_.EXPLODE" ss)
  421.       (while (> (getvar 'cmdactive) 0) (command ""))
  422.       (setq ss (ssget "_P"))
  423.       (repeat (setq i (sslength ss))
  424.         (setq li (ssname ss (setq i (1- i))))
  425.         (setq linlstt (cons li linlstt))
  426.       )
  427.     )
  428.   )
  429.   (foreach li linlstt
  430.     (setq livlalst (cons (vlax-ename->vla-object li) livlalst))
  431.   )
  432.   (setq reg (vlax-invoke ms 'AddRegion livlalst))
  433.   (setq ss (ssadd))
  434.   (foreach r reg
  435.     (setq ent (entlast))
  436.     (command "_.pedit" "_m")
  437.     (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke r 'explode)))
  438.     (command "" "_j" "" "")
  439.     (if
  440.       (and
  441.         (not (eq ent (setq ent (entlast))))
  442.         (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
  443.       )
  444.       (progn
  445.         (setq tmp (vlax-curve-getarea ent)
  446.               tot (+ tot tmp)
  447.         )
  448.         (if (< (car big) tmp)
  449.           (setq big (list tmp ent))
  450.         )
  451.         (ssadd ent ss)
  452.       )
  453.     )
  454.     (vla-delete r)
  455.   )
  456.   (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
  457.     (progn
  458.       (ssdel (cadr big) ss)
  459.       (entdel (cadr big))
  460.     )
  461.   )
  462.   (foreach obj livlalst (vla-delete obj))
  463.   (foreach pl (mapcar 'cadr (ssnamex ss))
  464.     (purge-pline pl)
  465.   )
  466.   (*error* nil)
  467. )
  468.  

Regards and hope you're all feeling good...
M.R.
Title: Re: split closed LWPOLY
Post by: ribarm on February 14, 2015, 12:02:46 PM
This is correct version... Should work in all kind of situations with LWPOLY in WCS... Test it, please, maybe I missed something...

See attachment - couldn't post in code tags as lisp is bigger now...

Regards, M.R.
Title: Re: split closed LWPOLY
Post by: ribarm on February 15, 2015, 12:25:21 AM
splitcllw-boundaryextensions.lsp updated... Now it uses plintav-new.lsp from PLINETOOLS from link posted above... Tell me if now something's wrong...

M.R.
Title: Re: split closed LWPOLY
Post by: DuanJinHui on May 27, 2015, 11:11:23 PM
Quote from: ribarm on February 15, 2015, 12:25:21 AM
splitcllw-boundaryextensions.lsp updated... Now it uses plintav-new.lsp from PLINETOOLS from link posted above... Tell me if now something's wrong...

M.R.

I test with  " split closed LWPOLY.dwg " 
only Leemac's code successful .

splitcllw-boundaryextensions-old.lsp + plintav-new.lsp  unsuccessful.
splitcllw-boundaryextensions.lsp  + plintav.lsp unsuccessful too.
I test with windows xp sp3 + autocad2007 and autocad 2010.
Title: Re: split closed LWPOLY
Post by: ribarm on May 28, 2015, 06:54:15 AM
Hi, have you tried splitcllw-boundaryextensions.lsp & plintav-new.lsp ? It worked well in the time routine was written with my tests... Make sure Lwpoly dont have bulges and that edges are concave (not convex)...
Title: Re: split closed LWPOLY
Post by: DuanJinHui on May 28, 2015, 07:12:11 AM
Quote from: ribarm on May 28, 2015, 06:54:15 AM
Hi, have you tried splitcllw-boundaryextensions.lsp & plintav-new.lsp ? It worked well in the time routine was written with my tests... Make sure Lwpoly dont have bulges and that edges are concave (not convex)...


hello ribarm
use "splitcllw-boundaryextensions.lsp" + "plintav-new.lsp"  ,need alittle modify ,

(if plinlst
    (progn
      (sssetfirst nil ss)
      (c:plintav)--->change to (c:plintav-new)
      (command "_.EXPLODE" ss)
      ....
      ....


I test with your drawing at #1
Code: [Select]
Select objects:
24 found
bad argument type: 2D/3D point: nil


Title: Re: split closed LWPOLY
Post by: ribarm on May 28, 2015, 08:01:53 AM
Hi, according to your picture, routine did the job for what was written... I dont know why it throwed an error and I dont know what do you want to achieve... Try debugging an error... I dont have currently PC and I am typing this from my phone so I cant help you much more... If in routine was written (c:plintav), then I suppose it may work as well and without plintav-new... If you want instead to get splitting of lwpoly shown at right of picture, you should use code posted at prevoius page (splitcllw)... I hope you can manage to accomplish desired task with yor knowledge... If something is struggling you, just ask... I think you will get desired answer as well good and without my help... Kind regards, M.R.
Title: Re: split closed LWPOLY
Post by: DuanJinHui on May 29, 2015, 06:07:39 AM
Quote from: ribarm on May 28, 2015, 08:01:53 AM
Hi, according to your picture, routine did the job for what was written... I dont know why it throwed an error and I dont know what do you want to achieve... Try debugging an error... I dont have currently PC and I am typing this from my phone so I cant help you much more... If in routine was written (c:plintav), then I suppose it may work as well and without plintav-new... If you want instead to get splitting of lwpoly shown at right of picture, you should use code posted at prevoius page (splitcllw)... I hope you can manage to accomplish desired task with yor knowledge... If something is struggling you, just ask... I think you will get desired answer as well good and without my help... Kind regards, M.R.

Hi ribarm.
last break souce at:
(car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
Title: Re: split closed LWPOLY
Post by: cjw on June 02, 2015, 09:05:47 PM
Maybe this way:
Title: Re: split closed LWPOLY
Post by: DuanJinHui on June 16, 2015, 02:43:25 AM
Quote from: cjw on June 02, 2015, 09:05:47 PM
Maybe this way:

can't understand.