多段线简化

aws

1. ;---去除多段线点集里面共线的点
   
2. (defun re-pts(en / pts pts1 pts2 pts3)
   
3.   (setq pts(mapcar 'cdr(vl-remove-if-not '(lambda(x)(=(car x)10))(entget en))))
   
4.   (if(vlax-curve-isClosed(vlax-ename->vla-object en))
   
5.     (progn
   
6.       (setq pts2(append(cdr pts)(list(car pts))))
   
7.       (setq pts3(append(cdr pts2)(list(car pts2))))
   
8.       (vl-remove nil(mapcar '(lambda(x1 x2 x3)(if(equal 0(chaji x1 x2 x3)0.01)nil x2))pts pts2 pts3))
   
9.     )
   
10.     (progn
    
11.       (setq pts1(reverse(cdr(cdr(reverse pts)))))
    
12.       (setq pts2(cdr(reverse(cdr(reverse pts)))))
    
13.       (setq pts3(cdr(cdr pts)))
    
14.       (append(list(car pts))(vl-remove nil(mapcar '(lambda(x1 x2 x3)(if(equal 0(chaji x1 x2 x3)0.01)nil x2))pts1 pts2 pts3))(list(last pts)))
    
15.     )
    
16.   )
    
17. )
    
18. ;---向量叉积，等于0代表共线
    
19. (defun chaji(p0 p1 p2)
    
20.   (-
    
21.     (*(-(car p1)(car p0))(-(cadr p2)(cadr p0)))
    
22.     (*(-(car p2)(car p0))(-(cadr p1)(cadr p0)))
    
23.   )
    
24. )

;---去除多段线点集里面共线的点<br /> (defun re-pts(en / pts pts1 pts2 pts3)<br />   (setq pts(mapcar 'cdr(vl-remove-if-not '(lambda(x)(=(car x)10))(entget en))))<br />   (if(vlax-curve-isClosed(vlax-ename->vla-object en))<br />     (progn<br />       (setq pts2(append(cdr pts)(list(car pts))))<br />       (setq pts3(append(cdr pts2)(list(car pts2))))<br />       (vl-remove nil(mapcar '(lambda(x1 x2 x3)(if(equal 0(chaji x1 x2 x3)0.01)nil x2))pts pts2 pts3))<br />     )<br />     (progn<br />       (setq pts1(reverse(cdr(cdr(reverse pts)))))<br />       (setq pts2(cdr(reverse(cdr(reverse pts)))))<br />       (setq pts3(cdr(cdr pts)))<br />       (append(list(car pts))(vl-remove nil(mapcar '(lambda(x1 x2 x3)(if(equal 0(chaji x1 x2 x3)0.01)nil x2))pts1 pts2 pts3))(list(last pts)))<br />     )<br />   )<br /> )<br /> ;---向量叉积，等于0代表共线<br /> (defun chaji(p0 p1 p2)<br />   (-<br />     (*(-(car p1)(car p0))(-(cadr p2)(cadr p0)))<br />     (*(-(car p2)(car p0))(-(cadr p1)(cadr p0)))<br />   )<br /> )

核心子函数如上，不支持含有圆弧的多段线。
如果加上圆弧，可能复杂一点，，，暂时没思路

kozmosovia

放着OVerkill不用自己写代码？

飞的鱼儿

这功能也不错的。

hubeiwdlue

谢谢分享，学习了。我换个思路写一个。

2. ;---向量叉积，等于0代表共线
   
3. (defun chaji(p0 p1 p2)
   
4.   (-
   
5.     (*(-(car p1)(car p0))(-(cadr p2)(cadr p0)))
   
6.     (*(-(car p2)(car p0))(-(cadr p1)(cadr p0)))
   
7.   )
   
8. )
   
9. ;去除一个线段中间共线节点
   
10. (defun rmp1(plst)
    
11.   (while (and(> (length plst) 2) (equal 0 (chaji (car plst) (cadr plst) (caddr plst)) 0.001))
    
12.     (setq plst (cons (car plst) (cddr plst)))
    
13.   )
    
14.   plst
    
15. )
    
16. ;院长的多段线函数
    
17. (defun xyp-Entmake-lwPolyline (ptlst Close-tnil / a s1)  
    
18.   (entmake (append (list '(0 . "LWPOLYLINE")
    
19.                      '(100 . "AcDbEntity")
    
20.                      '(100 . "AcDbPolyline")
    
21.                      (cons 90 (length ptlst))
    
22.                      (cons 70 (if Close-tnil 1 0))
    
23.                      (cons 38
    
24.                        (if (nth 2 (car ptlst))
    
25.                          (nth 2 (car ptlst))
    
26.                          0
    
27.                        )
    
28.                      )
    
29.                    )
    
30.              (mapcar '(lambda (a) (cons 10 a)) ptlst)
    
31.            )
    
32.   )
    
33.   (entlast)
    
34. )
    
35. ;去除共线点
    
36. (defun c:tt(/ )
    
37.   (setq en (car(entsel)))
    
38.   (setq p70 (cdr(assoc 70 (entget en))))
    
39.   (setq plst(mapcar 'cdr(vl-remove-if-not '(lambda(x)(=(car x)10))(entget en))))
    
40.   (setq plst1 nil)
    
41.   (while (> (length plst) 0)
    
42.     (setq plst (rmp1 plst))
    
43.     (setq plst1 (cons (car plst) plst1))
    
44.     (setq plst (cdr plst))
    
45.   )
    
46.   (setq plst1 (vl-remove nil (reverse plst1)))
    
47.   (if (= p70 0)
    
48.     (xyp-Entmake-lwPolyline plst1 nil)
    
49.     (xyp-Entmake-lwPolyline plst1 t)
    
50.   )
    
51. )

;---向量叉积，等于0代表共线<br /> (defun chaji(p0 p1 p2)<br />   (-<br />     (*(-(car p1)(car p0))(-(cadr p2)(cadr p0)))<br />     (*(-(car p2)(car p0))(-(cadr p1)(cadr p0)))<br />   )<br /> )<br /> ;去除一个线段中间共线节点<br /> (defun rmp1(plst)<br />   (while (and(> (length plst) 2) (equal 0 (chaji (car plst) (cadr plst) (caddr plst)) 0.001)) <br />     (setq plst (cons (car plst) (cddr plst)))<br />   )<br />   plst<br /> )<br /> ;院长的多段线函数<br /> (defun xyp-Entmake-lwPolyline (ptlst Close-tnil / a s1)  <br />   (entmake (append (list '(0 . "LWPOLYLINE")<br />                      '(100 . "AcDbEntity")<br />                      '(100 . "AcDbPolyline")<br />                      (cons 90 (length ptlst))<br />                      (cons 70 (if Close-tnil 1 0))<br />                      (cons 38<br />                        (if (nth 2 (car ptlst))<br />                          (nth 2 (car ptlst))<br />                          0<br />                        )<br />                      )<br />                    )<br />              (mapcar '(lambda (a) (cons 10 a)) ptlst)<br />            )<br />   )<br />   (entlast)<br /> )<br /> ;去除共线点<br /> (defun c:tt(/ )<br />   (setq en (car(entsel)))<br />   (setq p70 (cdr(assoc 70 (entget en))))<br />   (setq plst(mapcar 'cdr(vl-remove-if-not '(lambda(x)(=(car x)10))(entget en))))<br />   (setq plst1 nil)<br />   (while (> (length plst) 0) <br />     (setq plst (rmp1 plst))<br />     (setq plst1 (cons (car plst) plst1))<br />     (setq plst (cdr plst))<br />   )<br />   (setq plst1 (vl-remove nil (reverse plst1)))<br />   (if (= p70 0)<br />     (xyp-Entmake-lwPolyline plst1 nil)<br />     (xyp-Entmake-lwPolyline plst1 t)<br />   )<br /> )

有区别吗

我服了,正好今天碰上这个需求,还说没什么思路,上来看看,随手一点就有现成的了..

guankuiwu

圆弧还有有必要搞一搞的

Qwer1243

感谢分享，学习一下