Jump to content

LISP Routine to Specify Loops in a Network


andy_06

Recommended Posts

Hi,

 

I design utility networks and wonder if there is a way of finding where loops are in a network? I have attached a CAD drawing and I would like for a routine to somehow pick out the loops (i.e. node 2-3-7-8-8 / 3-4-5-6-7-3 / 2-3-4-6-7-8-2).

 

Thank you

WATER TEST.dwg

Link to comment
Share on other sites

It may be feasible using Bpoly to make a closed pline then walk along it finding the numbers, the open loops would need a temporary line for that to work.

 

For 2-3-4-6-7-8-2 remove leg 3-7 then its a loop. One of the things about lisp is that in this situation you can erase an object get all the points then do a UNDO but the points will still be in a lisp variable. I can see a problem with big networks how to determine a multitude of loop combos, with regards to increasing outwards.

 

 

 

 

Link to comment
Share on other sites

Apologies, maybe I am not using AutoCAD LT as I already use loads of LISP routines. My info says AutoCAD Autodesk 2017.

I need something that looks at the nodes on my drawing and determines where there are loops and then ideally exports the data to a CSV file.

Edited by andy_06
Link to comment
Share on other sites

No one replied with starting code... Here is my attempt that enters endless loop, so you'll have to debug it and further more, how is programmed it was to only collect numbers - loops are difficult task and if you even consider the fact that one loop can consist of 2, 3, or ... it's even more scary... What do you need this, if I may ask?

 

(defun c:loops ( / *error* consbylastpt doublepath-chk osm p s blk nolst lw lws lww lwss )

  (vl-load-com)

  (defun *error* ( m )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbylastpt ( lastpt lw / no blk )
    (if (< 
          (distance lastpt (cdr (assoc 10 (entget lw))))
          (distance lastpt (cdr (assoc 10 (reverse (entget lw)))))
        )
      (setq blk (ssname (ssget "_C" (cdr (assoc 10 (reverse (entget lw)))) (cdr (assoc 10 (reverse (entget lw)))) (list (cons 0 "INSERT") (cons 66 1))) 0))
      (setq blk (ssname (ssget "_C" (cdr (assoc 10 (entget lw))) (cdr (assoc 10 (entget lw))) (list (cons 0 "INSERT") (cons 66 1))) 0))
    )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
    blk
  )

  (defun doublepath-chk ( lw )
    (and
      (< 1 (sslength (ssget "_C" (cdr (assoc 10 (entget lw))) (cdr (assoc 10 (entget lw))) (list (cons 0 "LWPOLYLINE")))))
      (< 1 (sslength (ssget "_C" (cdr (assoc 10 (reverse (entget lw)))) (cdr (assoc 10 (reverse (entget lw)))) (list (cons 0 "LWPOLYLINE")))))
    )
  )

  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 1)
  (initget 1)
  (setq p (getpoint "\nPick starting node ending polylines - for ex. node 1..."))
  (if (setq s (ssget "_C" p p (list (cons 0 "INSERT") (cons 66 1))))
    (progn
      (setq blk (ssname s 0))
      (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
        (if (numberp (setq no (atoi (vla-get-textstring att))))
          (setq nolst (cons no nolst))
        )
      )
      (setq nolst (cdr nolst))
      (setq lw (ssname (ssget "_C" p p (list (cons 0 "LWPOLYLINE"))) 0))
      (setq blk (consbylastpt p lw))
      (setq p (cdr (assoc 10 (entget blk))))
      (setq lwss (ssdel lw (ssget "_C" p p (list (cons 0 "LWPOLYLINE")))))
      (setq lws (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex lwss))))
      (setq lws (vl-remove (setq lw (vl-some (function (lambda ( x ) (if (doublepath-chk x) x))) lws)) lws))
      (if lws
        (setq lww (car lws))
      )
      (while
        (and
          (not (vl-position (car nolst) (cdr nolst)))
          (setq p (cdr (assoc 10 (entget blk))))
          (< 1 (sslength (setq lwss (if lw (ssdel lw (ssget "_C" p p (list (cons 0 "LWPOLYLINE")))) (ssget "_C" p p (list (cons 0 "LWPOLYLINE")))))))
        )
        (setq lws (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex lwss))))
        (cond
          ( (vl-position lww lws)
            (setq blk (consbylastpt p lw))
          )
          ( (setq lw (vl-some (function (lambda ( x ) (if (doublepath-chk x) x))) lws))
            (setq blk (consbylastpt p lw))
          )
        )
      )
    )
  )
  (princ (reverse (cdr nolst)))
  (*error* nil)
)

 

 

It works only for nodes 1 and 9... If you manage to construct such situations for all branches, then you can get first loop as like (2 8 7 3) from picking 1 or 9...

Edited by marko_ribar
Link to comment
Share on other sites

Marko the dwg name gives the reason WATER its about water mains and the ability to turn a section off.

 

I did make a suggestion using bpoly pick inside a loop and can find the numbers using SSGET "F" the fence list is from the bpoly made.

 

Its very manual way to do it maybe have some time later to have a go.

 

 

 

 

Link to comment
Share on other sites

Like BIGAL, only I used SSGET "_CP"... You pick inside where boundary is to be created and it extract points representing loop... For bigger composed of 2 smaller, remove pline 3 7...

Here is the code, pretty simple :

 

(defun c:loops ( / *error* consbyblk osm clay p bound pl ss blk nolst )

  (vl-load-com)

  (defun *error* ( m )
    (if (and bound (not (vlax-erased-p bound)))
      (entdel bound)
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if clay
      (setvar (quote clayer) clay)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbyblk ( blk / no )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
  )

  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (setq clay (getvar (quote clayer)))
  (setvar (quote clayer) "0")
  (vl-cmdf "_.ZOOM" "_Extents")
  (initget 1)
  (if (setq p (getpoint "\nPick point inside loop..."))
    (progn
      (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (cond
        ( (= (strcase (getvar (quote program))) "BRICSCAD")
          (vl-cmdf "_.BOUNDARY" "_A" "_B" "_E" "_I" "_Y" "_X" p)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
        ( (= (strcase (getvar (quote program))) "ACAD")
          (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
          (vl-cmdf "_.BOUNDARY" "_A" "_B" "_N" "_ALL" "_I" "_Y" "_O" "_P")
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
          (bpoly p)
        )
      )
      (setq bound (entlast))
      (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
      (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (foreach p pl
        (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
          (progn
            (setq blk (ssname ss 0))
            (consbyblk blk)
          )
        )
      )
    )
  )
  (princ nolst)
  (*error* nil)
)

 

Edited by marko_ribar
Link to comment
Share on other sites

Here is the one that uses REGIONS, but the problem are nodes that lie collinear on 2 branches of LWPOLYLINES... When operating with regions and converting them to LWPOLYLINES those nodes are erased, so correct info is wrong... My suggestion is that you somehow tweak that collinearity to some nudge deviation in order to node be recognized...

Interestingly under ACAD everything is like expected... Only BricsCAD REGIONS are different - simplified at collinearity...

 

(defun c:loops ( / *error* consbyblk cmd osm clay pea el bound pl ss sss blk nolst nolstt )

  (vl-load-com)

  (defun *error* ( m )
    (if (and bound (not (vlax-erased-p bound)))
      (entdel bound)
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if clay
      (setvar (quote clayer) clay)
    )
    (if pea
      (setvar (quote peditaccept) pea)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbyblk ( blk / no )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq clay (getvar (quote clayer)))
  (setvar (quote clayer) "0")
  (setq pea (getvar (quote peditaccept)))
  (setvar (quote peditaccept) 1)
  (vl-cmdf "_.ZOOM" "_Extents")
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (setq el (entlast))
  (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  (setq sss (ssadd))
  (while (setq el (entnext el))
    (ssadd el sss)
  )
  (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (setq el (entlast))
  (vl-cmdf "_.REGION" sss "")
  (while (/= "REGION" (cdr (assoc 0 (entget (setq el (entnext el)))))))
  (while el
    (vl-cmdf "_.EXPLODE" el)
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
    (vl-cmdf "_.PEDIT" "_M" (ssget "_P") "" "_J")
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
    (setq bound (entlast))
    (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
    (entdel bound)
    (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
      (progn
        (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
      )
    )
    (foreach p pl
      (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
        (progn
          (setq blk (ssname ss 0))
          (consbyblk blk)
        )
      )
    )
    (setq nolstt (cons nolst nolstt))
    (setq nolst nil)
    (setq el (entnext el))
  )
  (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
    (progn
      (vl-cmdf "_.ERASE" sss)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  (if (and nolstt (listp nolstt) (listp (car nolstt)))
    (setq nolstt (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))
  )
  (princ nolstt)
  (*error* nil)
)

 

HTH.

M.R.

Edited by marko_ribar
Link to comment
Share on other sites

I had to make some deviations from collinearity, and it works only in AutoCAD; in BricsCAD it fails...

Return :

((3 2 8 7) (4 11 10 5) (5 6 7 3 4) (8 2 3 4 5 6 7) (6 7 3 4 11 10 5) (11 4 3 2 8 7 6 5 10))

 

Here is the code and new *.DWG...

 

(defun c:loops ( / *error* consbyblk process cmd osm clay pea el ell s ss sss nolstt )

  (vl-load-com)

  (defun *error* ( m )
    (if (and bound (not (vlax-erased-p bound)))
      (entdel bound)
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.UNDO" "_E")
        (vl-cmdf "_.UNDO" "_E")
      )
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if clay
      (setvar (quote clayer) clay)
    )
    (if pea
      (setvar (quote peditaccept) pea)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbyblk ( blk / no )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
  )

  (defun process ( ss p / nolst bound pl ss blk )
    (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
      (progn
        (setq bound (car (nentselp p)))
        (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
        (entdel bound)
        (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
          (progn
            (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (foreach p pl
          (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
            (progn
              (setq blk (ssname ss 0))
              (consbyblk blk)
            )
          )
        )
        (setq nolstt (cons nolst nolstt))
      )
      (progn
        (vl-cmdf "_.JOIN" ss)
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
        (setq bound (car (nentselp p)))
        (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
        (entdel bound)
        (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
          (progn
            (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (foreach p pl
          (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
            (progn
              (setq blk (ssname ss 0))
              (consbyblk blk)
            )
          )
        )
        (setq nolstt (cons nolst nolstt))
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq clay (getvar (quote clayer)))
  (setvar (quote clayer) "0")
  (setq pea (getvar (quote peditaccept)))
  (setvar (quote peditaccept) 1)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_M")
  (vl-cmdf "_.-OVERKILL" "_ALL")
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (vl-cmdf "_.ZOOM" "_Extents")
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (setq el (entlast))
  (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  (setq sss (ssadd))
  (while (setq el (entnext el))
    (ssadd el sss)
  )
  (if (= 0 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Lock" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (vl-cmdf "_.REGION" sss "")
  (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  (vl-cmdf "_.UNDO" "_G")
  (foreach el ell
    (vl-cmdf "_.EXPLODE" el)
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
    (setq s (ssget "_P"))
    (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
  )
  (vl-cmdf "_.UNDO" "_B")
  (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell))
  (entdel el)
  (foreach e1 ell
    (setq ell (vl-remove e1 ell))
    (foreach e2 ell
      (vl-cmdf "_.UNDO" "_G")
      (vl-cmdf "_.UNION" e1 e2)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (cond
        ( (and e1 (not (vlax-erased-p e1)))
          (vl-cmdf "_.EXPLODE" e1)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
        ( (and e2 (not (vlax-erased-p e2)))
          (vl-cmdf "_.EXPLODE" e2)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
        ( t
          (vl-cmdf "_.EXPLODE" "_L")
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
      )
      (if (wcmatch (cdr (assoc 0 (entget (ssname (setq s (ssget "_P")) 0)))) "LINE,ARC")
        (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
      )
      (vl-cmdf "_.UNDO" "_B")
    )
  )
  (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
    (progn
      (vl-cmdf "_.ERASE" sss)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
  (vl-cmdf "_.ERASE" ss)
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  (if (and nolstt (listp nolstt) (listp (car nolstt)))
    (setq nolstt (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))
  )
  (princ nolstt)
  (*error* nil)
)

 

HTH.

M.R.

 

 

WATER TEST-NEW.dwg

Edited by marko_ribar
Link to comment
Share on other sites

I've tried to solve for any tree of loops that may occur in complex situations... However, my mind stuck where I had to code for multiple nested (foreach) loops... Here is the code, so if some guru appear it would be nice that we feel relief upon finding general solution...

 

(defun c:loops ( / *error* consbyblk process consforeach closeparen body cmd osm clay pea el ell s ss sss nolstt n nn )

  (vl-load-com)

  (defun *error* ( m )
    (if (and bound (not (vlax-erased-p bound)))
      (entdel bound)
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.UNDO" "_E")
        (vl-cmdf "_.UNDO" "_E")
      )
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if clay
      (setvar (quote clayer) clay)
    )
    (if pea
      (setvar (quote peditaccept) pea)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbyblk ( blk / no )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
  )

  (defun process ( ss p / nolst bound pl ss blk )
    (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
      (progn
        (setq bound (car (nentselp p)))
        (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
        (entdel bound)
        (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
          (progn
            (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (foreach p pl
          (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
            (progn
              (setq blk (ssname ss 0))
              (consbyblk blk)
            )
          )
        )
        (setq nolstt (cons nolst nolstt))
      )
      (progn
        (vl-cmdf "_.JOIN" ss)
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
        (setq bound (car (nentselp p)))
        (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
        (entdel bound)
        (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
          (progn
            (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (foreach p pl
          (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
            (progn
              (setq blk (ssname ss 0))
              (consbyblk blk)
            )
          )
        )
        (setq nolstt (cons nolst nolstt))
      )
    )
  )
  ;;; this is problematic
  (defun consforeach ( n )
    (if (> n 0)
      (progn
        '(foreach (read (strcat "e" (itoa n))) ell
        (consforeach (1- n))
      )
    )
  )
  ;;; this is problematic
  (defun closeparen ( n )
    (if (> n 0)
      ')
      (closeparen (1- n))
    )
  )
  ;;; this is problematic
  (defun body ( n )
    (vl-cmdf "_.UNDO" "_G")
    (while (> n 0)
      (setq elst (cons (quote (read (strcat "e" (itoa (setq n (1- n)))))) elst))
      (vl-catch-all-apply (function vl-cmdf) (cons "_.UNION" elst))
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
    (foreach e elst
      (cond
        ( (and e (not (vlax-erased-p e)))
          (vl-cmdf "_.EXPLODE" e)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
        ( t
          (vl-cmdf "_.EXPLODE" "_L")
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
      )
    )
    (if (wcmatch (cdr (assoc 0 (entget (ssname (setq s (ssget "_P")) 0)))) "LINE,ARC")
      (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
    )
    (vl-cmdf "_.UNDO" "_B")
  )
  ;;;
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq clay (getvar (quote clayer)))
  (setvar (quote clayer) "0")
  (setq pea (getvar (quote peditaccept)))
  (setvar (quote peditaccept) 1)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_M")
  (vl-cmdf "_.-OVERKILL" "_ALL")
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (vl-cmdf "_.ZOOM" "_Extents")
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (setq el (entlast))
  (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  (setq sss (ssadd))
  (while (setq el (entnext el))
    (ssadd el sss)
  )
  (if (= 0 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Lock" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (vl-cmdf "_.REGION" sss "")
  (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  (vl-cmdf "_.UNDO" "_G")
  (foreach el ell
    (vl-cmdf "_.EXPLODE" el)
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
    (setq s (ssget "_P"))
    (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
  )
  (vl-cmdf "_.UNDO" "_B")
  (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell))
  (entdel el)
  (setq nn (length ell))
  ;;; this is problematic
  (while (> nn 0)
    (setq nn (1- nn))
    (consforeach nn)
    (body nn)
    (closeparen nn)
  )
  ;;;
  (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
    (progn
      (vl-cmdf "_.ERASE" sss)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
  (vl-cmdf "_.ERASE" ss)
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  (if (and nolstt (listp nolstt) (listp (car nolstt)))
    (setq nolstt (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))
  )
  (princ nolstt)
  (*error* nil)
)

 

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...