[编程交流] 检查多段线是否具有duplic

(defun c:test ( / LM:UniqueFuzz LM:MAssoc ss i e ) (vl-load-com)
 ;; © Lee Mac 2011
 (defun LM:UniqueFuzz-p ( lst fuzz )
   (or (null lst)
     (and (not (vl-member-if '(lambda ( x ) (equal x (car lst) fuzz)) (cdr lst)))
       (LM:UniqueFuzz-p (cdr lst) fuzz)
     )
   )
 )
 (defun LM:MAssoc ( key lst / pair )
   (if (setq pair (assoc key lst))
     (cons (cdr pair) (LM:MAssoc key (cdr (member pair lst))))
   )
 )
 (if (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss))
     (if (LM:UniqueFuzz-p (LM:MAssoc 10 (entget (setq e (ssname ss (setq i (1- i)))))) 1e-
       (ssdel e ss)
     )
   )
 )
 (sssetfirst nil ss)
 (princ)
)

(defun c:testVVA (/ UniqueLineFuzz  ss i el ss1 lst1)
 (vl-load-com)
 (defun UniqueLineFuzz (lst fuzz)
   (if lst
     (cons
       (car lst)
       (UniqueLineFuzz
         (vl-remove-if
           '(lambda (x)
              (apply 'and
                     (mapcar '(lambda (l1 l2 / sl1 el1 sl2 el2)
                                (setq
                                  sl1 (mapcar '+
                                              (vlax-curve-getstartpoint l1)
                                              '(0 0)
                                      ) ;_ end of mapcar
                                  el1 (mapcar '+
                                              (vlax-curve-getendpoint l1)
                                              '(0 0)
                                      ) ;_ end of mapcar
                                  sl2 (mapcar '+
                                              (vlax-curve-getstartpoint l2)
                                              '(0 0)
                                      ) ;_ end of mapcar
                                  el2 (mapcar '+
                                              (vlax-curve-getendpoint l2)
                                              '(0 0)
                                      ) ;_ end of mapcar
                                ) ;_ end of setq
                                (or
                                  (and
                                    (equal (car sl1) (car sl2) fuzz)
                                    (equal (cadr sl1) (cadr sl2) fuzz)
                                    (equal (car el1) (car el2) fuzz)
                                    (equal (cadr el1) (cadr el2) fuzz)
                                  ) ;_ end of and
                                  (and
                                    (equal (car sl1) (car el2) fuzz)
                                    (equal (cadr sl1) (cadr el2) fuzz)
                                    (equal (car el1) (car sl2) fuzz)
                                    (equal (cadr el1) (cadr sl2) fuzz)
                                  ) ;_ end of and
                                ) ;_ end of or
                              ) ;_ end of lambda
                             (list x)
                             lst
                     ) ;_ end of mapcar
              ) ;_ end of apply
            ) ;_ end of lambda
           (cdr lst)
         ) ;_ end of vl-remove-if
         fuzz
       ) ;_ end of LM:UniqueSegFuzz
     ) ;_ end of cons
   ) ;_ end of if
 ) ;_ end of defun
 (if (setq ss (ssget "_:L" '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss))
     (setq el (ssname ss (setq i (1- i))))
     (setq lst (vlax-safearray->list
                 (vlax-variant-value
                   (vla-explode (vlax-ename->vla-object el))
                 ) ;_ end of vlax-variant-value
               ) ;_ end of vlax-safearray->list
           lst (vl-remove-if '(lambda (x)(equal (vlax-curve-getDistAtParam x(vlax-curve-getEndParam x)) 0.0 1e-6)) lst)
     ) ;_ end of setq
     (setq lst1
            (mapcar 'vlax-vla-object->ename (UniqueLineFuzz lst 1e-6))
     ) ;_ end of setq
     (setq ss1 (ssadd (car lst1)))
     (mapcar '(lambda (x) (ssadd x ss1)) (cdr lst1))
     (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
       (vl-cmdf "_pedit" "_Multiple" ss1 "" "_Join" 0 "")
       (vl-cmdf "_pedit" "_Multiple" ss1 "" "_Y" "_Join" 0 "")
     ) ;_ end of if
     (entdel el)
     (mapcar '(lambda (x)
                (if (not (vlax-erased-p x))
                  (vla-delete x)
                ) ;_ end of if
              ) ;_ end of lambda
             lst
     ) ;_ end of mapcar
   ) ;_ end of repeat
 ) ;_ end of if
 (princ)
) ;_ end of defun

(mapcar '+ < .. >  '(0 0))