多段线（LWPOL- POL) 整理、消重、合并

尘缘一生 · 发表于 2023-1-18 04:01:01

本帖最后由尘缘一生于 2023-1-18 04:30 编辑

如题：测试成功
代码均在《三领设计》测试并完成集成，
链接：https://pan.baidu.com/s/1kUzjxcRPoWbxxMZ7nM8T0Q
提取码：ilgd

;;删除超短、合并重叠-近邻及单根之重合点消重------(一级)--------
;;支持-->LWPOLYLINE,POLYLINE
;;三领设计 V3.0 BY 尘缘一生 QQ 15290049
(defun unduppl (s fuzz / i j lst lst1 lis1 lis2 lstx lsty lstx1 lsty1 tp p1 p2 nm len0 n ss nam enam1 enam2 spt1 ept1 spt2 ept2 d1 d2 d3 d4 obj vb_pt0 vb_endpt end_index)
;;判断a是否在 a1至a2两点连线上
(defun on_ent_1 (a a1 a2)
(equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.01)
)
;;--------------------
(setq lst (get-box s) p1 (car lst) p2 (cadr lst))
(setq nm 0 len0 (sslength s))
;;删除长度小于 0.01的多段线
(repeat (setq n (sslength s))
(setq nam (ssname s (setq n (1- n))))
(if (<= (sllen nam) 0.01)
(progn
(ssdel nam s)
(entdel nam)
(setq nm (1+ nm))
)
)
)
;合并|连接重复、共线的 LWPOLYLINE,POLYLINE-----
(repeat (setq n (sslength s))
(setq enam1 (ssname s (setq n (1- n))) tp (dxf1 enam1 0))
(if (member tp '("LWPOLYLINE" "POLYLINE"))
(progn
(setq lis1 (order-pt (get-pl-pt enam1)))
(setq spt1 (car lis1) ept1 (last lis1))
(if
(setq ss
(ssget
"CP"
(list
(polar spt1 (angle ept1 spt1) 2)
(polar ept1 (- (angle spt1 ept1) pi4) 2.5)
(polar ept1 (+ (angle spt1 ept1) pi4) 2.5)
)
'((0 . "POLYLINE,LWPOLYLINE"))
)
)
(progn
(ssdel enam1 ss) ;;次选择集先删除主线
(if (> (sslength ss) 0) ;确保ss存在实体
(progn
(repeat (setq j (sslength ss))
(setq nam (ssname ss (setq j (1- j))))
(if (not (ssmemb nam s)) (ssdel nam ss)) ;;如果主选择集都没有，次选择集去除它
) ;以上确保主集S 次集 SS 正确
(if (> (sslength ss) 0) ;如果现在还ss存在实体
(repeat (setq j (sslength ss))
(setq enam2 (ssname ss (setq j (1- j))))
(setq lis2 (order-pt (get-pl-pt enam2)))
(setq spt2 (car lis2) ept2 (last lis2))
(if (= (sl:pts-onLine (append lis1 lis2)) t) ;共线
(cond
((and (on_ent_1 spt2 spt1 ept1) (on_ent_1 ept2 spt1 ept1)) ;;次线落在主线上
(ssdel enam2 ss)
(if (ssmemb enam2 s) ;如果次线也是主线选择集之一
(progn
(ssdel enam2 s)
(setq nm (1+ nm))
)
)
(entdel enam2) ;;删除次线
)
((and (on_ent_1 spt1 spt2 ept2) (on_ent_1 ept1 spt2 ept2)) ;;主线落在次线上
(entdel enam1) ;;删除主线
(setq nm (1+ nm))
(setq enam1 enam2 spt1 spt2 ept1 ept2 lis1 lis2) ;次线转主线
)
((or
(or (on_ent_1 spt2 spt1 ept1) (on_ent_1 ept2 spt1 ept1)) ;;次线其中一点在主线上
(and
(= (on_ent_1 spt2 spt1 ept1) nil) ;次线短点1不在主线
(= (on_ent_1 ept2 spt1 ept1) nil) ;次线短点2也不在主线
(setq d1 (distance spt1 spt2))
(setq d2 (distance spt1 ept2))
(setq d3 (distance ept1 spt2))
(setq d4 (distance ept1 ept2))
(< (min d1 d2 d3 d4) fuzz) ;但两线之间最短距离!
)
)
(setq lst (order-pt (list spt1 ept1 spt2 ept2)))
(setq spt1 (car lst)) ;下次扩展延伸选择用
(setq ept1 (last lst)) ;下次扩展延伸选择用
(setq lis1 (list spt1 ept1))
(ssdel enam2 ss)
(if (ssmemb enam2 s) ;如果次线也是主线选择集之一
(progn
(ssdel enam2 s)
(setq nm (1+ nm))
)
)
(entdel enam2) ;;删除次线
(setq
obj (en2obj enam1)
vb_pt0 (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble '(0 . 1)) (list (car spt1) (cadr spt1)))
vb_endpt (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble '(0 . 1)) (list (car ept1) (cadr ept1)))
end_index (fix (vlax-curve-getParamAtPoint obj (vlax-curve-getendPoint obj)))
)
(vla-put-Coordinate obj 0 vb_pt0);起点
(vla-put-Coordinate obj end_index vb_endpt);终点
)
) ;cond
) ;if
);end repeat
);if
)
)
)
)
)
)
)
;; 以下集成可以注销不用
;;删除完全重合------
(if (setq ss (ssget "C" p1 p2 '((0 . "POLYLINE,LWPOLYLINE"))))
(progn
(setq i 0 n (sslength ss)) ;初始化变量,设置i为1的原因是方便j取值
(repeat (1- n) ;外循环开始,循环次数为多段线个数减1
(setq lst (get-pl-pt (ssname ss i)))
(setq lstx (mapcar 'car (vl-sort lst '(lambda (a b) (< (car a) (car b)))))) ;按照X坐标从小到大排序并提取X坐标组成表
(setq lsty (mapcar 'cadr (vl-sort lst '(lambda (a b) (< (cadr a) (cadr b)))))) ;按照Y坐标从小到大排序并提取Y坐标组成表
(setq i (1+ i))
(setq j i) ;j的值为i
(repeat (- n i) ;内循坏开始,循坏次数为多段线个数减去i
(setq nam (ssname ss j))
(setq lst1 (get-pl-pt nam))
(setq lstx1 (mapcar 'car (vl-sort lst1 '(lambda (a b) (< (car a) (car b))))))
(setq lsty1 (mapcar 'cadr (vl-sort lst1 '(lambda (a b) (< (cadr a) (cadr b))))))
(if (and (equal lstx lstx1 1e-5) (equal lsty lsty1 1e-5)) ;对比两个X和两个Y的表看是否一致,一致就删除
(progn
(entdel nam)
(setq nm (1+ nm))
)
)
(setq j (1+ j))
)
)
)
)
;;删除重合点、共线点-------
(if (setq ss (ssget "C" p1 p2 '((0 . "POLYLINE,LWPOLYLINE"))))
(progn
(repeat (setq i (sslength ss))
(setq nam (ssname ss (setq i (1- i))) tp (dxf1 nam 0))
(cond
((= tp "LWPOLYLINE")
(x@-delvx nam nil nil)
)
((= tp "POLYLINE")
(dump2dPoly nam)
)
)
)
)
)
(prompt
(strcat
(slmsg " 处理" " 矪瞶" " Delete Merge")
(itoa len0)
(slmsg "个*POLYLINE" "*POLYLINE" "Num-*POLYLINE")
(slmsg "消去" "" "delete")
(itoa nm)
(slmsg "个" "" "num")
)
)
(princ)
)

Ming131564 · 发表于 2023-1-18 09:11:54

大佬的代码厉害了

vladimir · 发表于 2023-2-6 15:51:52

非常好的代码，谢谢楼主分享啊。

xpeagle · 发表于 2024-1-25 12:03:42

厉害了，试试，多谢分享了，赞一个

账号		自动登录	找回密码
密码			注册

多段线（LWPOL- POL) 整理、消重、合并

浏览过的版块