多段线点清理

木香 · 发表于 2021-9-24 16:29:45

本帖最后由木香于 2021-9-24 16:29 编辑

;;应该有很多小伙伴对多段线上杂乱的点有强迫症,抛个砖,发个清理多线共线及重复点的段子,代码内容还有待优化
(defun c:plcl (/ a data delst lay llst llst2 m n name newdata p43 p70 ss)
(if (and (setq ss (ssget (list (cons 0 "LWPOLYLINE")))) (setq m 0))
(repeat (sslength ss)
(setq name (ssname ss m))
(setq data (entget name))
(setq p70 (cdr (assoc 70 data)));闭合性
(setq lay (cdr (assoc 8 data)));图层
(setq p43 (cdr (assoc 43 data)));线宽
(setq llst (coordinates3d-list name));端点表
(setq llst2 (list (car llst)));构造仅含有效点的新点表
(setq n 1);从第二点开始比较
(setq delst '())
(while (<= n (- (length llst) 2))
(if (or
(> (length (cadr (list-frequnt2 (nth n llst) llst 0.1))) 1);在容差0.1以内的存在重复点
(< (setq a (lines-ang (nth n llst) (nth (1- n) llst) (nth n llst) (nth (1+ n) llst))) 0.1);连续的点存在共线点
)
(setq delst (cons (nth n llst) delst))
(setq llst2 (cons (nth n llst) llst2));构造仅含有效点的新点表
)
(setq n (1+ n))
)
(if (or
(> (length (cadr (list-frequnt2 (last llst) llst 0.1))) 1)
(< (setq a (lines-ang (last llst) (car llst) (car llst) (cadr llst))) 0.1)
)
(setq delst (cons (last llst) delst))
(setq llst2 (cons (last llst) llst2))
);第一点单独处理，与末位点及第二点判断重复、共线关系
(reverse llst2)
(if (not (= (length llst) (length llst2)))
(progn
(setq newdata
(entget
(entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (1- (length llst2))) (cons 70 p70) (cons 8 lay) (cons 62 1))
(mapcar '(lambda (x)(cons 10 x)) llst2))
)
)
);创建新多段线
(entupd (cdr (assoc -1 (entmod (subst (cons 43 p43) (assoc 43 newdata) newdata)))))
(entdel name);删除旧多段线
)
;(princ "\n没有需要处理的多段线")
)
(setq m (1+ m))
)
)
(princ)
)
;两直线夹角（锐角值）
(defun lines-ang (p1 p2 p3 p4 / ang1)
(setq ang1 (abs (- (angle p1 P2) (angle p3 P4))));
(cond
((and (> ang1 (* pi 0.5)) (<= ang1 pi)) (setq ang1 (- pi ang1)))
((and (> ang1 pi) (<= ang1 (* pi 1.5))) (setq ang1 (- ang1 pi)))
((and (> ang1 (* pi 1.5)) (<= ang1 (* pi 2))) (setq ang1 (- (* pi 2) ang1)))
)
ang1
)
;(list-frequnt2 '(1.01 50) (list '(1.01 50) '(1.01 50.01) '(2 100) '(2.01 100.01) '(1.1 50)) 0.01)
;;返回表内重复元素及在表内的次序(带容差值)
(defun list-frequnt2 (lstmember lst fuzz / el n orlst)
(setq orlst '())
(setq n 0)
(repeat (length lst)
(setq el (nth n lst))
(if (equal lstmember el fuzz)
(setq orlst (cons n orlst))
)
(setq n (1+ n))
)
(if orlst
(setq orlst (reverse orlst))
)
(list lstmember orlst)
)
;;抄来的函数
;;调试：(setq lsta (coordinates3d-list (car (entsel "\n请选择曲线"))))
;;简介: 取得曲线顶点，适用于：样条曲线-"SPLINE"；三维多段线"-POLYLINE"；多义线-"LWPOLYLINE"；椭圆弧-"ELLIPSE"；圆弧-"ARC"；直线-"line"
;;二级子函数： ch-lst
;;调用格式： (ch-lst ei lsti)
(defun coordinates3d-list (e / obj pname lst)
(defun ch-lst (ei lsti / ind nn lstn lsti1)
(setq ind 0
nn (if (= (cdr (assoc 0 (entget ei))) "LWPOLYLINE") 2 3)
lstn '()
)
(repeat (/ (length lsti) nn)
(if (= (cdr (assoc 0 (entget ei))) "LWPOLYLINE")
(setq lsti1 (list (nth ind lsti) (nth (1+ ind) lsti) (cdr (assoc 38 (entget ei)))))
(setq lsti1 (list (nth ind lsti) (nth (1+ ind) lsti) (nth (+ 2 ind) lsti)))
)
(setq lstn (cons lsti1 lstn)
ind (+ ind nn)
)
)
(setq lstn (reverse lstn))
);二级子函数
(vl-load-com)
(setq obj (vlax-ename->vla-object e)
pname (cdr (assoc 0 (entget e)))
)
(cond
((= pname "SPLINE")
(setq lst (ch-lst e (vlax-safearray->list (vlax-variant-value (vla-get-ControlPoints obj)))))
)
((or (= pname "LWPOLYLINE") (= pname "POLYLINE"))
(setq lst (ch-lst e (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates obj)))))
)
(T
(setq lst (list (vlax-safearray->list (vlax-variant-value (vla-get-StartPoint obj)))
(vlax-safearray->list (vlax-variant-value (vla-get-EndPoint obj))))
)
)
)
lst
)

烟盒迷唇 · 发表于 2021-9-25 10:52:19

论坛里好像有过类似的功能，不知道哪个更好用。

849881146 · 发表于 2021-12-14 10:38:03

支持！！！！！！！！！！！！！！！！！

夏生生 · 发表于 2021-12-14 16:06:25

烟盒迷唇发表于 2021-9-25 10:52
论坛里好像有过类似的功能，不知道哪个更好用。

CAB写过一个

qazxswk · 发表于 2022-2-8 14:43:16

代码在浩辰上使用有问题，选择多段线后，多段线会消失。

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

[经验] 多段线点清理