Author Topic: split closed LWPOLY  (Read 9215 times)

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
split closed LWPOLY
« 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...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: split closed LWPOLY
« Reply #1 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.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: split closed LWPOLY
« Reply #2 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...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

LE3

  • Guest
Re: split closed LWPOLY
« Reply #3 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.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: split closed LWPOLY
« Reply #4 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))))
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

LE3

  • Guest
Re: split closed LWPOLY
« Reply #5 on: July 17, 2014, 12:58:17 PM »
--- 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


Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: split closed LWPOLY
« Reply #6 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)
« Last Edit: July 17, 2014, 04:20:43 PM by Lee Mac »

LE3

  • Guest
Re: split closed LWPOLY
« Reply #7 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.... :-(

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: split closed LWPOLY
« Reply #8 on: July 17, 2014, 02:47:53 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 :)

LE3

  • Guest
Re: split closed LWPOLY
« Reply #9 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!

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: split closed LWPOLY
« Reply #10 on: July 17, 2014, 04:17:54 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.

But I see that does the job --- Good!

Thanks Luis, I appreciate you taking the time to test it :)

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: split closed LWPOLY
« Reply #11 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...
« Last Edit: July 18, 2014, 02:59:10 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: split closed LWPOLY
« Reply #12 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... :-)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

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

:)

M.R. on Youtube

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: split closed LWPOLY
« Reply #14 on: August 02, 2014, 10:22:48 AM »
Nice job, works in ACAD2006  :)
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.