[编程交流] lisp用于多重修剪和扩展

(defun c:plintav-new ( / intersobj1obj2 LM:Unique AT:GetVertices add_vtx clean_poly
                        ss sslpl sshpl i ent n ent1 ss-ent1 k ent2 intpts intptsall pl plpts 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 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)
 )
 (defun clean_poly ( ent / trunc e_lst p_lst )
   (defun trunc ( expr lst )
     (if (and lst (not (equal (car lst) expr)))
       (cons (car lst) (trunc expr (cdr lst)))
     )
   )
   (setq e_lst (entget ent))
   (if (= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
     (progn
       (setq p_lst 
                   (vl-remove-if-not 
                    '(lambda (x)
                       (or (= (car x) 10)
                           (= (car x) 40)
                           (= (car x) 41)
                           (= (car x) 42)
                       )
                     )
                     e_lst
                   )
             e_lst 
                   (vl-remove-if
                    '(lambda (x)
                       (member x p_lst)
                     )
                     e_lst
                   )
       )
       (if (= 1 (logand (cdr (assoc 70 e_lst)) 1))
         (while (equal (car p_lst) (assoc 10 (reverse p_lst)))
           (setq p_lst (reverse (cdr (member (assoc 10 (reverse p_lst)) (reverse p_lst)))))
         )
       )
       (while p_lst
         (setq e_lst (append e_lst (trunc (assoc 10 (cdr p_lst)) p_lst))
               p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))
         )
       )
       (entmod e_lst)
     )
   )
   (princ)
 )
 (setq ss (ssget "_:L" (list '(0 . "*POLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 1) '(70 . 128) '(70 . 129) '(-4 . "or>") (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))
 (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 intptsall (append plpts intptsall))
 )
 (setq i -1)
 (while (setq pl (ssname sslpl (setq i (1+ i))))
   (foreach pt intptsall
     (if (setq par (vlax-curve-getparamatpoint pl pt))
       (add_vtx (vlax-ename->vla-object pl) par pl)
     )
   )
 )
 (repeat (setq n (sslength sslpl))
   (clean_poly (ssname sslpl (setq n (1- n))))
 )
 (setq i -1)
 (while (setq ent (ssname sshpl (setq i (1+ i))))
   (command "_.convertpoly" "h" ent "")
 )
 (princ)
)