Conditional Trimming

[edmondsforum]

Dear ALL,

Firstly, please forgive my poor English,

I have two questions:

 

Q1:
I'm looking for a LISP routine that can do conditional trimming.

Currently, I have an irregularly closed polyline in my drawing, referred to as BpolyA, along with horizontal and vertical line segments spaced 80m apart, referred to as Grid80.

I want to be able to delete things outside of Grid80 based on BpolyA, with the desired result shown in the 'after' image. Is there any way to do this?

 

Q2:
I have a LISP routine that can create a region based on BpolyA and Grid80.

But there's a problem with the first step, 'Extrim'. Is there a way to also delete objects outside of BpolyA?

 

Here is the example DWG

test.dwg

 

here is the lisp to make regeion

(defun C:KE88 ()  
(alert "Please be sure to copy it to the side first before proceeding with the operation.")
(C:EXTRIM)
(C:epll)
(alert "Upon completion of the operation, an additional area will be created within the base range. Please remember to delete it.")
(princ)
)


(defun c:epll ( / *error* break_object l2p ms ss i z_dir o_dir e lst segments pa dr aa ce reg ea layer_name layer color_code current_layer) 
  (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
  (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
  (vla-startundomark acDoc)
  (setq pa (getvar 'peditaccept)
        dr (getvar 'draworderctl)
        ce (getvar 'cmdecho)
        aa 0.00
        layer_name "Regeion"
        color_code 6
  )

  ;; Check if the layer exists, if not, create a new layer.
  (if (not (tblsearch "LAYER" layer_name))
    (progn
      (setq layer (vla-add (vla-get-layers acDoc) layer_name))
      (vla-put-color layer color_code)
    )
  )

  ;; Save the current layer, and set the current layer to the 'Regeion' layer.
  (setq current_layer (vla-get-ActiveLayer acDoc))
  (vla-put-ActiveLayer acDoc (vla-item (vla-get-layers acDoc) layer_name))
  
  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
      (princ (strcat "\nError: " msg))
      )
    (foreach x (append segments lst) (vl-catch-all-apply 'vla-delete (list x)))
    (setvar 'peditaccept pa)
    (setvar 'draworderctl dr)
    (setvar 'cmdecho ce)
    (vla-endundomark acDoc)
    (princ)
  )
  
  (defun l2p (l) (if l (cons (list (car l) (cadr l) (caddr l)) (l2p (cdddr l)))))
  
  (defun break_object (e points / object_type start center end radius normal arc res)
    (if points
      (progn
        (setq points
          (vl-sort points
            (function
              (lambda (a b)
                (<
                  (vlax-curve-getdistatpoint e (vlax-curve-getclosestpointto e a))
                  (vlax-curve-getdistatpoint e (vlax-curve-getclosestpointto e b))
                )
              )
            )
          )
        )
        (cond
          ((eq (setq object_type (vla-get-ObjectName e)) "AcDbLine")
           (setq start (vlax-curve-getstartpoint e))
           (while points
             (if (> (distance start (car points)) 1e-5)
               (setq res (cons (vlax-invoke ms 'addline start (setq start (car points))) res))
               )
             (setq points (cdr points))
             )
           )
          (T
           (if
             (eq object_type "AcDbArc")
             (setq start  (vlax-curve-getStartParam e))
             (setq start  (vlax-curve-getparamatpoint e (car points))
                   points (reverse (cons (car points) (reverse (cdr points))))
             )
           )
           (setq   center (vla-get-Center e)
                   radius (vla-get-Radius e)
                   normal (vla-get-Normal e)
           )
           (while points
             (if (not (equal start (setq end (vlax-curve-getparamatpoint e (car points))) 1e-5))
               (progn
                 (setq arc (vla-AddArc ms center radius start end))
                 (vla-put-Normal arc normal)
                 (setq res (cons arc res))
               )
             )
             (setq points (cdr points)
                   start end)
             )
           )
         )
       )
     )
    res
  )
         
  (if
    (setq ss (ssget ":L" '((0 . "LINE,LWPOLYLINE,ARC,CIRCLE"))))
    (progn
      (setq z_dir (trans '(0 0  1) 1 0 t))
      (repeat (setq i (sslength ss))
        (setq i (1- i)
              e (ssname ss i)
              o_dir (cdr (assoc 210 (entget e)))
              e (vlax-ename->vla-object e)
        )
        (if
          (equal o_dir z_dir 1e-8)
          (if
            (eq (vla-get-ObjectName e) "AcDbPolyline")
            (foreach x (vlax-invoke e 'Explode)
              (setq lst (cons x lst))
            )
            (setq lst (cons (vla-copy e) lst))
          )
        )
      )
      (if
        (and
          (setq segments
            (apply 'append
              (mapcar
                (function
                  (lambda (e / l)
                    (break_object e
                      (progn
                        (foreach other (vl-remove e lst)
                          (foreach x (l2p (vlax-invoke e 'intersectwith other acExtendNone))
                             (if
                               (equal x (vlax-curve-getclosestpointto e x) 1e-8)
                               (setq l (cons x l))
                             )
                          )
                        )
                        (if
                          (eq (vla-get-ObjectName e) "AcDbCircle")
                          l
                          (cons (vlax-curve-getendpoint e) l)
                        )
                      )
                    )
                  )
                )
                lst
              )
            )
          )
          (not
            (vl-catch-all-error-p
              (setq reg
               (vl-catch-all-apply 'vlax-invoke (list ms 'AddRegion segments))
              )
            )
          )
        )
        (progn
          (setvar 'peditaccept 1)
          (setvar 'draworderctl 0)
          (setvar 'cmdecho 0)
          (foreach x reg
            (setq x (vlax-vla-object->ename x))
            (entmod (append (entget x) (list (cons 8 layer_name))))
          )          
          (setvar 'peditaccept pa)
          (setvar 'draworderctl dr)
          (setvar 'cmdecho ce)
        )
        (princ "\nValid region(s) not found")
      )
    )
  )
  (*error* nil)
  (princ)
)

 

[mhupp]

Q1.  probably not what you want but create small squares 80x80 & create a grid over the polyline. then use the following lisp.

 

;;----------------------------------------------------------------------;;
;;DELETE ALL outside Polyline
(defun C:PCross (/ SS1 SS2 coords)
  (setq SS1 (ssget)) ;Select everything
  (if (setq SS (ssget "_+.:E:S" '((0 . "*POLYLINE")))) ;select polyline
    (progn
      (setq coords (vl-remove-if 'not (mapcar (function (lambda (p) (if (= 10 (car p)) (cdr p)))) (entget (ssname SS 0)))))
      (setq SS2 (ssget "_CP" coords))
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS2)))
        (ssdel ent SS1)
      )
    ) 
  )
  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS1)))
    (entdel ent)
  )
  (princ)
)

[BIGAL]

Have a look at this a few changes but will do what you want.

 

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/dynamically-draw-grid-from-lee-mac/td-p/9950301

[edmondsforum]

Dear mhupp,
Thank you for providing this method, 

[edmondsforum]

Dear BIGAL

 

Thank you for ur method, but my GRID must be created using LINE, not Block.
because for slope analysis use.....

[BIGAL]

Try Cookie Cutter.lsp sometimes much better than extrim.

Edited June 10, 2023 by BIGAL

[edmondsforum]

On 6/10/2023 at 12:54 PM, BIGAL said:

Try Cookie Cutter.lsp sometimes much better than extrim.

 

Thank you for the reminder, that's exactly the function I need!