[编程交流] 删除多段线或对象输出

; Required Express tools
; OutSide Contour Delete with Extrim
; Found at http://forums.augi.com/showthread.php?t=55056
(defun C:OCD (  / en ss lst ssall bbox)
(vl-load-com)
  (if (and (setq en (car(entsel "\nSelect contour (polyline): ")))
           (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
    (progn
      (setq bbox (ACET-ENT-GEOMEXTENTS en))
      (setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
      (setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3))
      (ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
      (command "_.Zoom" "0.95x")
      (if (null etrim)(load "extrim.lsp"))
      (etrim en (polar
                  (car bbox)
                  (angle (car bbox)(cadr bbox))
                  (* (distance (car bbox)(cadr bbox)) 1.1)))
      (if (and
            (setq ss (ssget "_CP" lst))
            (setq ssall (ssget "_X" (list (assoc 410 (entget en)))))
           )
        (progn
          (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
          (foreach e1 lst (ssdel e1 ssall))
          (ACET-SS-ENTDEL ssall)
          )
        )
      )
    )
  )
(princ "\nType OCD to start")
(princ)

; Required Express tools
; OutSide Contour Delete with Extrim
; Found at http://forums.augi.com/showthread.php?t=55056
; Modified for multiple contour processing by M.R.
(defun C:OCD ( / *error* LM:ConvexHull LM:Clockwise-p entnextparent adoc cmde sel i el en ss sss lst cp ssall bbox enx laylst elst fuzz )
  (vl-load-com)
  (defun *error* ( m )
    (if cmde
      (setvar 'cmdecho cmde)
    )
    (vla-endundomark adoc)
    (if m
      (prompt m)
    )
    (princ)
  )
  ;; Convex Hull  -  Lee Mac
  ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
  (defun LM:ConvexHull ( lst / ch p0 )
      (cond
          (   (< (length lst) 4) lst)
          (   (setq p0 (car lst))
              (foreach p1 (cdr lst)
                  (if (or (< (cadr p1) (cadr p0))
                          (and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
                      )
                      (setq p0 p1)
                  )
              )
              (setq lst (vl-remove p0 lst))
              (setq lst (append (list p0) lst))
              (setq lst
                  (vl-sort lst
                      (function
                          (lambda ( a b / c d )
                              (if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
                                  (< (distance p0 a) (distance p0 b))
                                  (< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 d))
                              )
                          )
                      )
                  )
              )
              (setq ch (list (cadr lst) (car lst)))
              (foreach pt (cddr lst)
                  (setq ch (cons pt ch))
                  (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
                      (setq ch (cons pt (cddr ch)))
                  )
              )
              (reverse ch)
          )
      )
  )
  ;; Clockwise-p  -  Lee Mac
  ;; Returns T if p1,p2,p3 are clockwise oriented or collinear
  (defun LM:Clockwise-p ( p1 p2 p3 )
      (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
              (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
          )
          1e-8
      )
  )
  (defun entnextparent ( e )
    (while (and (setq e (entnext e)) (wcmatch (cdr (assoc 0 (entget e))) "ATTRIB,VERTEX,SEQEND")))
    e
  )
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (if (= 8 (logand 8 (getvar 'undoctl)))
    (vla-endundomark adoc)
  )
  (setq cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (prompt "\nSelect contour polylines: ")
  (while (not (setq sel (ssget "_:L" '((0 . "*POLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>")))))
    (prompt "\nEmpty sel.set... Retry selecting again...")
  )
  (if (tblsearch "LAYER" "temp_layer")
    (progn
      (prompt "\nLayer "temp_layer" already present in active document... Please delete this layer as it is used by this routine and restart OCD again...")
      (exit)
    )
  )
  (if (null etrim) (load "extrim.lsp"))
  (initget 6)
  (setq fuzz (getdist "\nPick or specify fuzz distance for interpolation of reference polyline(s) <0.5> : "))
  (if (null fuzz)
    (setq fuzz 0.5)
  )
  (repeat (setq i (sslength sel))
    (if laylst
      (progn
        (setq el (entlast))
        (vl-cmdf "_.PASTECLIP" "_non" '(0.0 0.0 0.0))
        (while (setq el (entnextparent el))
          (setq elst (cons el elst))
        )
      )
    )
    (vla-startundomark adoc)
    (setq en (ssname sel (setq i (1- i))))
    (setq bbox (ACET-ENT-GEOMEXTENTS en))
    (setq bbox (mapcar '(lambda ( x ) (trans x 0 1)) bbox))
    (setq lst (ACET-GEOM-OBJECT-POINT-LIST en fuzz))
    (setq cp (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (car bbox) (cadr bbox)))
    (setq lst (mapcar '(lambda ( x ) (mapcar '+ cp (mapcar '* (mapcar '- x cp) (list 1.05 1.05 1.05)))) lst))
    (setq lst (LM:ConvexHull lst))
    (vl-cmdf "_.ZOOM" "_OB" en "")
    (vl-cmdf "_.ZOOM" "0.75x")
    (etrim en (polar (car bbox) (angle (car bbox) (cadr bbox)) (* (distance (car bbox) (cadr bbox)) 1.1)))
    (vl-cmdf "_.ZOOM" "_P")
    (vl-cmdf "_.ZOOM" "_P")
    (if (setq ss (ssget "_CP" lst))
      (progn
        (setq sss (ssadd))
        (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
          (setq enx (entget (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object e)))))
          (setq laylst (cons (cdr (assoc 8 enx)) laylst))
          (entupd (cdr (assoc -1 (entmod (subst (cons 8 "temp_layer") (assoc 8 enx) enx)))))
          (ssadd (cdr (assoc -1 enx)) sss)
        )
      )
    )
    (vl-cmdf "_.COPYBASE" "_non" '(0.0 0.0 0.0) sss "")
    (vl-cmdf "_.UNDO" "_B")
  )
  (setq el (entlast))
  (vl-cmdf "_.PASTECLIP" "_non" '(0.0 0.0 0.0))
  (while (setq el (entnextparent el))
    (setq elst (cons el elst))
  )
  (setq ssall (ssget "_X" (list (cons 8 "~temp_layer"))))
  (ACET-SS-ENTDEL ssall)
  (mapcar '(lambda ( a b ) (entupd (cdr (assoc -1 (entmod (subst (cons 8 b) '(8 . "temp_layer") (entget a))))))) elst laylst)
  (vl-cmdf "_.PURGE" "_LA" "temp_layer" "_N")
  (*error* nil)
)