检查多段线是否具有duplic
请帮助解决这个问题，我需要检查多段线是否有重复点，如果发现重复数据，如何删除重复数据或重新绘制没有重复点的多段线？LW多段线图层：“0”
空间：模型空间
手柄=2b61
关闭
恒定宽度0.00
面积64011440.00
周长39926.72
在点X=7416.00 Y=24813.00 Z=0.00处
在点X=13106.00 Y=22431.00 Z=0.00处
在点X=13549.00 Y=16850.00 Z=0.00处
在点X=9597.00 Y=15387.00 Z=0.00处
在点X=3395.00 Y=16919.00 Z=0.00处
在点X=5269.00 Y=21036.00 Z=0.00处
在点X=7416.00 Y=24813.00 Z=0.00处
在点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)
…….
试试看
(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 1lst)
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_lststart_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)
)
非常感谢你的帮助！我需要消化你的价值信息。 尊敬的VVA：，
谢谢你的lisp，我正在测试lisp，发现了一个小问题。lisp无法绘制正确的多段线，如下所示：
附着dwg文件，plz
感谢您快速回复VVA，附上测试用图纸。
新建块。图纸 程序运行以下算法：
仅保留第一个重复点。其他已删除。我不知道如何通过编程确定他们需要什么来保持重复点。在您的情况下，我建议尝试使用主题LISP中的命令ECO。生态-物体的外部轮廓。至少我得到了要求的结果
感谢您的善意协助，如果发现任何重复点，然后在其上再复制一条多段线如何。你能做到吗？
谢谢 除非我完全误解了预期结果，否则这行得通吗？
(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)
)
非常感谢李的帮助！
页:
[1]
2