[编程交流] 删除边界外的对象

(defun c:pDel (/ GroupByNum _GetLocked lst->str ENT I LK OBJ PTLST SS)
 (vl-load-com)
 ;; Lee Mac  ~  02.04.10
 (defun GroupByNum (lst num / rtn)
   (setq rtn nil)
   
   (if lst
     (cons (reverse
             (repeat num
               (progn
                 (setq rtn (cons (car lst) rtn)
                       lst (cdr lst))
                 rtn)))
           (GroupByNum lst num))))
 
 (defun _GetLocked (/ tdef lk)
   (while (setq tdef (tblnext "LAYER" (not tdef)))
     (if (= 4 (logand 4 (cdr (assoc 70 tdef))))
       (setq lk (cons (cdr (assoc 2 tdef)) lk)))))
 
 (defun lst->str (lst del / str)
   (setq str (car lst))
   (while (setq lst (cdr lst)) (setq str (strcat str del (car lst))))
 str)  
 
 (while
   (progn
     (setq ent (car (entsel "\nSelect Polyline: ")))
     (cond (  (eq 'ENAME (type ent))
              (if (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
                (progn
                  (setq ptLst
                    (GroupByNum
                      (vlax-get
                        (setq obj (vlax-ename->vla-object ent)) 'Coordinates)
                      (if (eq "AcDbPolyline" (vla-get-ObjectName obj)) 2 3)))
                  (if (cadr
                        (sssetfirst nil
                          (setq i -1 ss
                            (ssget "_WP" ptLst
                                   (if (setq lk (_GetLocked))
                                     (list (cons -4 "<NOT")
                                           (cons 8 (lst->str lk ",")) (cons -4 "NOT>")))))))
                    (if (progn
                          (initget "Yes No")
                          (not (eq "No" (getkword "\nDelete Objects? [Yes/No] <Yes> : "))))
                      (while (setq ent (ssname ss (setq i (1+ i))))
                        (entdel ent))
                      (sssetfirst nil nil))
                    (princ "\n** No Objects Found **")))
                (princ "\n** Object Must be a Polyline **"))))))
 (princ))

;;; Erase in or out of polyline  LPS 2010-04-02
(defun c:test (/ idx obj endparam cnt pnt ss1)
(vl-load-com)
 (setq ptlst nil)
 (setq ss1 nil)
 (setq obj (vlax-ename->vla-object (car (setq pl (entsel "\nSelect polyline boundary: ")))))
 (if (or; test if polyline and has area
   (/= (vlax-get-property obj 'ObjectName) "AcDbPolyline")
   (zerop (vlax-get-property obj 'Area))
   )
   (princ "\nSelected entity is not a polyline or can not be used for a section window")
   )
 (setq p1 (getpoint "Pick side to erase: ")
   pnt (entmakex
       (list (cons 0 "point")
          (cons 10 p1))
        )
   )
         
 (setq ptlst (list (vlax-curve-getStartPoint obj))    
   idx 1)
 (if (zerop (vlax-get obj 'Closed))
       (setq endparam (vlax-curve-getParamAtPoint obj (vlax-curve-getEndPoint obj)));if open param at end point
   (setq endparam (cdr (assoc 90 (entget (vlax-vla-object->ename obj)))));if closed # vertices
   )
    
 (while
   (<= idx endparam)
     (if;test for curve -  thanks to Lee Mac and others
   (not
     (equal
           (angle '(0 0 0)
             (vlax-curve-getSecondDeriv obj (1- idx))) 0.0 1e-
     );not
   (progn
     (setq cnt (1- idx))
     (repeat 15;divide curve
       (setq ptlst(cons (vlax-curve-getPointAtParam obj (+ cnt 0.0625)) ptlst)
             cnt (+ 0.0625 cnt))
       );repeat
     );progn
   );if
  (setq ptlst (cons (vlax-curve-getPointAtParam obj idx) ptlst)
    idx (1+ idx))
  );while
 (setq ptlst (reverse ptlst))
 (setq ss1  (ssget "_WP" ptlst))
 (if
   (ssmemb pnt ss1)
     (vl-cmdf "erase" ss1 "")
   (progn
     (setq ss1  (ssget "_CP" ptlst))
     (vl-cmdf "erase" "all" "r" ss1 pl ""))
   )
 
  (princ)
 );defun

(defun c:EIO (/ _p2ss o ent ssIn ssOut)
 ;; Erase Inside/Outside of selected LWPolyline
 ;; Alan J. Thompson, 04.02.10
 (vl-load-com)
 (or *EIO:Opt* (setq *EIO:Opt* "Inside"))
 (setq _p2ss (lambda (ename)
               (ssget "_WP"
                      ((lambda (e / l)
                         (foreach x e (and (eq 10 (car x)) (setq l (cons (cdr x) l))))
                         (reverse l)
                       ) ;_ lambda
                        (entget ename)
                      )
               ) ;_ ssget
             ) ;_ lambda
 ) ;_ setq
 (and (setq o (car (entsel "\nSelect LWPolyline: ")))
      (or (eq "LWPOLYLINE" (cdr (assoc 0 (setq ent (entget o)))))
          (alert "Invalid object!")
      ) ;_ or
      (not (initget 0 "Inside Outside"))
      (setq *EIO:Opt*
             (cond
               ((getkword (strcat "\nSpecify erase option [inside/Outside] <" *EIO:Opt* ">: ")))
               (*EIO:Opt*)
             ) ;_ cond
      ) ;_ setq
      (cond
        ((and (eq *EIO:Opt* "Inside") (setq ssIn (_p2ss o)))
         ((lambda (i)
            (while (setq e (ssname ssIn (setq i (1+ i))))
              (or (eq o e) (vl-catch-all-apply (function entdel) (list e)))
            ) ;_ while
          ) ;_ lambda
           -1
         )
        )
        ((eq *EIO:Opt* "Outside")
         (setq ssIn  (_p2ss o)
               ssOut (ssget "_X" (list (cons 410 (getvar 'ctab))))
         ) ;_ setq
         ((lambda (i)
            (while (setq e (ssname ssOut (setq i (1+ i))))
              (if ssIn
                (or (ssmemb e ssIn) (eq o e) (vl-catch-all-apply (function entdel) (list e)))
                (or (eq o e) (vl-catch-all-apply (function entdel) (list e)))
              ) ;_ if
            ) ;_ while
          ) ;_ lambda
           -1
         )
        )
      ) ;_ cond
 ) ;_ and
 (princ)
) ;_ defun