多段线（LWPOL- POL) 整理、消重、合并
本帖最后由 尘缘一生 于 2023-1-18 04:30 编辑如题：测试成功
代码均在《三领设计》测试并完成集成，
链接：https://pan.baidu.com/s/1kUzjxcRPoWbxxMZ7nM8T0Q
提取码：ilgd
[*];;删除超短、合并重叠-近邻及单根之重合点消重------(一级)--------
[*];;支持-->LWPOLYLINE,POLYLINE
[*];;三领设计 V3.0BY 尘缘一生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)
[*])
大佬的代码厉害了 非常好的代码， 谢谢楼主分享啊。 厉害了，试试，多谢分享了，赞一个
页:
[1]