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

(defun c:pp (/ ename vla_obj thelist)
(setq mspace (vla-get-modelSpace (vla-get-activeDocument
   (vlax-get-acad-object))))
       (setq ename (car (entsel "\n select object:"))
               vla_obj (vlax-ename->vla-object ename))
                        (if (=(vlax-get-property vla_obj 'objectname) "acdbpolyline")
                               (progn
                                 (setq thelist (vlax-get-property vla_obj 'coordinates)
…….

(defun C:TEST ( / pl lst vertex_lst start_width_lst end_width_lst bulge_lst )
 (vl-load-com)
 (and
   (setq pl (car(entsel "Select Polyline: ")))
   (= (cdr(assoc 0 (entget pl))) "LWPOLYLINE")
   (setq lst (pl:get-coors&width&bulge pl)
      vertex_lst (nth 0 lst)
      start_width_lst (nth 1  lst)
      end_width_lst   (nth 2 lst)
      bulge_lst (nth 3 lst)
      )
   (setq vertex_lst (mip_MakeUniqueMembersOfList vertex_lst))
   (pl-set-coors&width&bulge pl vertex_lst  start_width_lst end_width_lst bulge_lst)
  )
 )
;;;Функция возвращает список координат ширин и кривизн полилинии
;;; pl-ename or vla object
;;; Возвращается список ввиде 4 списков
;;; 1-й список координат (WCS)
;;; 2-й список начальная ширина 
;;; 3-й список конечная ширина
;;; 4-й список кривизн
(defun pl:get-coors&width&bulge ( pl / ent_data tmp_ent start_width end_width blglist coors)
(setq pl (pl:conv-ent-to-ename PL))  
 (setq ent_data (entget pl))
 (if (= (cdr(assoc 0 ent_data))  "LWPOLYLINE")
   (foreach lst ent_data
     (setq num (car lst))
     (cond
       ((= num 10)(setq coors (cons (cdr lst) coors)))
       ((= num 40)(setq start_width (cons (cdr lst) start_width)))
       ((= num 41)(setq end_width (cons (cdr lst) end_width)))
       ((= num 42)(setq blglist (cons (cdr lst) blglist)))
       (t nil)
       )
     )
   (progn
     (setq tmp_ent pl)
     (while (/= "SEQEND" (cdr(assoc 0 (setq ent_data (entget(setq tmp_ent (entnext tmp_ent)))))))
       
            (setq coors (cons (cdr (assoc 10 ent_data))  coors))
            (setq start_width (cons (cdr (assoc 40 ent_data)) start_width))
            (setq end_width (cons (cdr (assoc 41 ent_data)) end_width))
            (setq blglist (cons (cdr (assoc 42 ent_data)) blglist))
   );_while
     )
   )
 (list (reverse coors)
       (reverse start_width)
       (reverse end_width)
       (reverse blglist)
       )
 )
(defun pl-set-coors&width&bulge ( pl coors start_width end_width blglist / ent_data tmp_lst i)
(setq pl (pl:conv-ent-to-ename PL))  
(setq ent_data (entget pl))
 (cond ((= (cdr(assoc 0 ent_data))  "LWPOLYLINE")
             (setq ent_data (vl-remove-if
                          '(lambda (x)(vl-position (car x) '(40 41 42 10))) ent_data))
              (mapcar '(lambda (crs sw ew blg)
                         (setq tmp_lst (vl-list*
                                             (cons 42 blg)
                                             (cons 41 ew)
                                             (cons 40 sw)
                                             (cons 10 (list (car crs)(cadr crs)))
                                             tmp_lst
                                             )
                                       )
                         )
                                    coors start_width end_width blglist
                      )
        
             (setq ent_data (append ent_data (reverse tmp_lst)))
             ;(mapcar '(lambda (x) (setq ent_data (append ent_data x))) tmp_lst)
             (setq ent_data (subst (cons 90 (fix(* 0.25 (length tmp_lst)))) (assoc 90 ent_data) ent_data))
             (entmod ent_data)
             (entupd pl)
 )
       (t  (setq i (cadddr (assoc 10 ent_data))) ;_Z value
           (setq coors (mapcar '(lambda(x / Z)
                                  (setq Z (caddr x))
                                  (if (null Z)(setq Z i))
                                  (list (car x)(cadr x) Z)) coors))
           (setq tmp_lst (apply 'append coors))
           (vla-put-coordinates (setq i (pl:conv-ent-to-vla PL))(vlax-make-variant (vlax-safearray-fill
           (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length tmp_lst)))) tmp_lst)))
         (setq pl (pl:conv-ent-to-ename i))   
         (setq tmp_lst pl i 0)
 (while (/= "SEQEND" (cdr(assoc 0 (setq ent_data (entget(setq tmp_lst (entnext tmp_lst)))))))
   (setq ent_data (entget tmp_lst))
   (if (nth i start_width)
     (setq ent_data (subst (cons 40 (nth i start_width))(assoc 40 ent_data) ent_data)))
   (if (nth i end_width)
     (setq ent_data (subst (cons 41 (nth i end_width))(assoc 41 ent_data) ent_data)))
   (if (nth i blglist)
     (setq ent_data (subst (cons 42 (nth i blglist))(assoc 42 ent_data) ent_data)))
          (entmod ent_data)(setq i (1+ i))                 
   );_while
; (entmake (cdr (entget tmp_lst)))
 ;(entdel ent_name)
   (entupd pl)
 ))
 pl)
   ;|=============================================================================
*    Функция преобразования полученного значения в ename
*    Параметры вызова:
*        ent_value        значение, которое надо преобразовать в примитив. Может
*                        быть:
*                       -    именем примитива,
*                       -    vla-указателем,
*                       -    меткой,
*                       -    спиком entget,
*                       -    спиком entsel.
*                        Если не принадлежит ни одному из указанных типов,
*                        возвращается nil
*    Примеры вызова:
(pl:conv-ent-to-ename (entlast))
(pl:conv-ent-to-ename (entget(entlast)))
(pl:conv-ent-to-ename (cdr(assoc 5 (entget(entlast)))))
(pl:conv-ent-to-ename (car(entsel)))
(pl:conv-ent-to-ename (vlax-ename->vla-object (entlast)))
=============================================================================|;
(defun pl:conv-ent-to-ename (ent_value / ret)
 (cond
   ((= (type ent_value) 'vla-object) (vlax-vla-object->ename ent_value))
   ((= (type ent_value) 'ename) ent_value)
   ((and (= (type ent_value) 'list)
         (= (type (setq ret (car ent_value))) 'ename)
         )
    ret
    )
   ((and (= (type ent_value) 'str)(setq ret (handent ent_value))) ret)
   ((= (type ent_value) 'list)(cdr (assoc -1 ent_value)))
   (t nil)
   ) ;_ end of cond
 ) ;_ end of defun
;|=============================================================================
*    Функция преобразования полученного значения в vla-указатель.
*    Параметры вызова:
*        ent_value        значение, которое надо преобразовать в примитив. Может
*                        быть:
*                       -    именем примитива,
*                       -    vla-указателем,
*                       -    меткой,
*                       -    спиком entget,
*                       -    спиком entsel.
*                        Если не принадлежит ни одному из указанных типов,
*                        возвращается nil
*    Примеры вызова:
(pl:conv-ent-to-vla (entlast))
(pl:conv-ent-to-vla (entget(entlast)))
(pl:conv-ent-to-vla (cdr(assoc 5 (entget(entlast)))))
(pl:conv-ent-to-vla (car(entsel)))
(pl:conv-ent-to-vla (vlax-ename->vla-object (entlast)))
=============================================================================|;
(defun pl:conv-ent-to-vla (ent_value / ret)
 (cond
   ((= (type ent_value) 'vla-object) ent_value)
   ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
   ((setq ret (pl:conv-ent-to-ename ent_value))(vlax-ename->vla-object ret))
   (t nil)
   ) ;_ end of cond
 ) ;_ end of defun
(defun mip_MakeUniqueMembersOfList  ( lst / OutList head)
;;;Удаляет одинаковые (дубликаты) элементы из списка
;;; На основе http://www.theswamp.org/index.php?topic=19128.0
;;; Изменено для сравнения вещественных чисел (equal ... 1e-6)
 (while lst
   (setq head (car lst)
         OutList (cons head OutList)
         lst (vl-remove-if '(lambda(pt)(equal pt head 1e-6))(cdr lst))
         )
   )
 (reverse OutList)
 )

(defun c:test ( / LM:UniqueFuzz LM:MAssoc ss i el ) (vl-load-com)
 ;; © Lee Mac 2011
 (defun LM:UniqueFuzz ( lst fuzz )
   (if lst
     (cons (car lst)
       (LM:UniqueFuzz
         (vl-remove-if '(lambda ( x ) (equal x (car lst) fuzz)) (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 "_:L" '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss)) (setq el (entget (ssname ss (setq i (1- i)))))
     (if
       (entmakex
         (append (reverse (member (assoc 39 el) (reverse el)))
           (mapcar '(lambda ( x ) (cons 10 x)) (LM:UniqueFuzz (LM:MAssoc 10 el) 1e-) (list (assoc 210 el))
         )
       )
       (entdel (cdr (assoc -1 el)))
     )
   )
 )
 (princ)
)