check the polyline have duplicated point

June 7, 2011

Please help for solve this problem, I need to check the polyline have duplicated point or not , if I found duplicated data, how to delete the duplicate data or redraw the polyline without duplicate point?

LWPOLYLINE Layer: "0"

Space: Model space

Handle = 2b61

Closed

Constant width 0.00

area 64011440.00

perimeter 39926.72

at point X= 7416.00 Y= 24813.00 Z= 0.00

at point X= 13106.00 Y= 22431.00 Z= 0.00

at point X= 13549.00 Y= 16850.00 Z= 0.00

at point X= 9597.00 Y= 15387.00 Z= 0.00

at point X= 3395.00 Y= 16919.00 Z= 0.00

at point X= 5269.00 Y= 21036.00 Z= 0.00

at point X= 7416.00 Y= 24813.00 Z= 0.00

at point X= 5269.00 Y= 21036.00 Z= 0.00

(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)
…….

June 7, 2011

Try it

(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)
 )

June 7, 2011

Try it

(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)
 )

Thank you so much for your help ! I need to digest your value information.

June 7, 2011

Dear VVA,

Thank you for your lisp, I'm testing the lisp and found a minor problem. The lisp can't draw the correct polyline as shown below:

June 7, 2011

Attach dwg file, plz

June 7, 2011

Attach dwg file, plz

Thanks for your quickly reply VVA, attach dwg for your test.

new block.dwg

June 7, 2011

The program runs the following algorithm:

remain only the first duplicate point. Others are deleted. I do not know how to programmatically determine what they need to keep repeating points. In your case I would suggest to try the command ECO from the topic LISP. ECO - External Contour of Objects. At least I get the required result

June 8, 2011

The program runs the following algorithm:
remain only the first duplicate point. Others are deleted. I do not know how to programmatically determine what they need to keep repeating points. In your case I would suggest to try the command ECO from the topic LISP. ECO - External Contour of Objects. At least I get the required result

Thank you for your kindly assist, how about if any duplicated point found and then copy one more polyline on top of it . Can you do that ?

Thanks !

June 8, 2011

Unless I am completely misunderstanding the desired result, would this work?

(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)
)

June 8, 2011

Unless I am completely misunderstanding the desired result, would this work?

(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)
)

Thank you very much for your help Lee Mac !

June 8, 2011

Unless I am completely misunderstanding the desired result, would this work?

(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)
)

After running your lisp, the polyine changed to another shape. I think it is the same as VVA said, it is hard to determine which point need to keep.

LWPOLYLINE Space: Model space

Handle = 2cab

Closed

Constant width 0.00

area 14153723.23

perimeter 21581.35

at point X= -9771.00 Y= -7388.00 Z= 0.00

at point X= -8116.00 Y= -9826.00 Z= 0.00

at point X= -9771.00 Y= -7388.00 Z= 0.00

at point X=-13222.00 Y=-11647.00 Z= 0.00

at point X=-10528.48 Y=-13202.10 Z= 0.00

at point X= -8116.00 Y= -9826.00 Z= 0.00

LWPOLYLINE

Space: Model space

Color: 9 Linetype: "BYLAYER"

Handle = 2da0

Closed

Constant width 0.00

area 6952768.87

perimeter 17341.12

at point X= -9771.00 Y= -7388.00 Z= 0.00

at point X= -8116.00 Y= -9826.00 Z= 0.00

at point X=-13222.00 Y=-11647.00 Z= 0.00

at point X=-10528.48 Y=-13202.10 Z= 0.00

Let me explain more about my situation. Although this is a one closed polyline, but one segment has two line overlapping inside. There are some duplicated points showing the overlapping location. I want to use the lisp to check the polylines, If any duplicated line found, it will automatically delete it. If it is difficult to determine which lines/points need to keep, is it possible to show which polylines have this overlapping only.

Thanks !

June 8, 2011

This will select all LWPolylines with Duplicate Points:

(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)
)

June 8, 2011

Try it

(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

Edited June 9, 2011 by VVA
Correct Arc length

June 9, 2011

This will select all LWPolylines with Duplicate Points:

(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)
)

Thank you for your code Lee Mac !

June 9, 2011

Try it

(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 (vla-get-Length 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

Thank you very much for your help VVA, this code is working ! Thanks again VVA and Lee Mac for kindly assist.

June 9, 2011

Try it

(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 (vla-get-Length 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

I try use this lisp on polyline have arc inside, the program return the following error message :

ActiveX Server returned the error: unknown name: Length

Is it only work on line only ?

June 9, 2011

Correct #13 (how lucky ) Try again

June 9, 2011

VVA, just curious, why:

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

Obviously the (0 0) is not affecting the result in any way so are you using this method to ensure the return from mapcar is a 2D point?

June 13, 2011

This will select all LWPolylines with Duplicate Points:
(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)
)
[/QUOTe

Dear Lee Mac,

I try to digest your code for few days, may be I'm the beginner of lisp int is hard to understand it. Can your explain more about above function. And how to duplicate a polylines on top of existing polylines when it have duplicate point found ? Thanks a lot !

June 13, 2011

I'm sure Lee wouldn't mind this:

(defun c:test (/ LM:UniqueFuzz LM:MAssoc ss i e)
 (vl-load-com)
 ;; © Lee Mac 2011

 (defun LM:UniqueFuzz-p (lst fuzz) ;Define a localized defun inside c:test
   (or (null lst) ;If lst is empty - or
       (and ;and the 2 following apply
         (not (vl-member-if ;The following is not a member of the residual of lst
                '(lambda (x) (equal x (car lst) fuzz))
;Temporary function to check equality to a fuzz of the 1st item in lst
                (cdr lst) ;The residual of lst
              )
         )
         (LM:UniqueFuzz-p (cdr lst) fuzz) ;Call this function again with the residual of the list
       )
   )
 )

 (defun LM:MAssoc (key lst / pair) ;Define a localized defun inside c:test
   (if (setq pair (assoc key lst)) ;Check if there is an assoc
     (cons (cdr pair) ;Return a new list containing the 1st assoc found, plus
           ;;The other assocs found by calling this same function with only the residual of the list
           (LM:MAssoc key (cdr (member pair lst)))
     )
   )
 )

 (if (setq ss (ssget "_X" '((0 . "LWPOLYLINE")))) ;If any LWPolies found
   (repeat (setq i (sslength ss)) ;Loop through each
     ;; Use the above 2 functions to check if the current one is unique
     (if (LM:UniqueFuzz-p (LM:MAssoc 10 (entget (setq e (ssname ss (setq i (1- i)))))) 1e-
       (ssdel e ss) ;Then remove it from the selection set
     )
   )
 )
 (sssetfirst nil ss) ;Select the resulting selection set
 (princ)
)

It uses recursion extensively ... something which you'll find a lot in lisp. I.e. a function calling itself in order form a loop. This is sometimes better / easier / more efficient than using the normal while / repeat / etc. loops. In the above case it's one of these times.

Also notice Lee's stepping through the list from the last entity - decrementing the i (index) variable. There's 2 reasons behind this: (1) it's slightly more efficient than the other way round; and (2) because he's removing elements from the selection set, the length changes - thus if #4 is remove, then the old #5 becomes the new #4, so incrementing i would skip some items.

Sign In

check the polyline have duplicated point

Recommended Posts

ahyin

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Posted Images

VVA

ahyin

ahyin

VVA

ahyin

VVA

ahyin

Lee Mac

ahyin

ahyin

Lee Mac

VVA

ahyin

ahyin

ahyin

VVA

Lee Mac

ahyin

irneb

Join the conversation

Tutorials

Forums

Activity