多线段删点lsp

wzg

1. ;wzg 修改于20150417
   
2. (defun c:plsd ( / en HH:delLwpolyPt1)
   
3. ;;示例(HH:delLwpolyPt1 (car(setq en(entsel))) (cadr en)) By 自贡黄明儒
   
4. (defun HH:delLwpolyPt1 (en p / ENT L1 L2 P1)
   
5.   (setq ENT (entget en))
   
6.   (setq p (vlax-curve-getclosestpointto en (trans p 1 0)))
   
7.   (setq p1 (HH:PickClosePt en p))                            ;离p最近的顶点
   
8.   (setq p1 (list 10 (car p1) (cadr p1)))
   
9.   (setq L2 (cdr (member p1 ent)))                            ;后段
   
10.   (setq L1 (reverse (cdr (member p1 (reverse ent)))))            ;前段
    
11.   (entmod (append L1 L2))
    
12. )
    
13. ;;164.19 [功能] 多段线所点击点最近的一个顶点  By 自贡黄明儒
    
14. ;;示例(HH:PickClosePt (car(setq en(entsel))) (cadr en))
    
15. (defun HH:PickClosePt (obj p / N P1 P2 PP)
    
16.   (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
    
17.         n  (fix (vlax-curve-getparamatpoint obj pp))
    
18.   )
    
19.   (setq p1 (vlax-curve-getPointAtParam obj n))
    
20.   (setq p2 (vlax-curve-getPointAtParam obj (1+ n)))
    
21.   (if (< (distance pp p1) (distance pp p2))
    
22.     p1    p2
    
23.   )
    
24. )
    
25. ;;---------------------------
    
26. (initget "  ")
    
27. (setq en (entsel "\n点击要删除的多线段顶点..."))
    
28. (cond
    
29.         ((= en "")nil)
    
30.         ((and en(wcmatch(cdr(assoc 0(entget(car en))))"LWPOLYLINE"))
    
31.                 (HH:delLwpolyPt1 (car en) (cadr en))
    
32.                  (c:plsd)
    
33.         )
    
34.         (t (c:plsd))       
    
35. )
    
36. (princ)
    
37. )

复制代码

对方水电费的

厉害了！！！

XWIFN

只能是直线或多段线，刷成坎属性就加不了

suihan001

过来学习学习，查漏补缺一下

昊园江南一品

学习一下

ntcgh

分享学习，共同提高