[LISP程序]：增加、删除pl多义线顶点

梦断江南

先加载plve.lsp
方法参考http://www.fspdi.com/forum/showthread.php?s=&threadid=291
执行过程：
1.命令行下敲plve命令
  command:plve
2.选择 pl 线
3.取点
  （当取点在顶点时，删除捕捉到的顶点；当取点不在顶点时，增加顶点）
4.(如果为增加顶点时)选择新的定位点/回车为在取点处增加顶点

2. 
   
3. (defun c:plve ( / os en entl pt ptend)
   
4.   (princ "\n plve====lwpolyline vert edit,增加/删除pl线顶点--vb1.0--------lxx.2001.7")
   
5.   (setvar "modemacro" "plve.多义线顶点增删程序--梁雄啸.2001")
   
6.   (setvar "cmdecho" 0)
   
7.   (setvar "osmode" 551)
   
8.   (princ "\n当取点为 pl 线的顶点时---删除/否---增加顶点")
   
9.   (setq        os   (getvar "osmode")
   
10.         en   (entsel "\n选择要增/删顶点的多义线:")
    
11.         ent  (car en)
    
12.   )
    
13.   (initget 128)
    
14.   (princ "\n!!!取点为 pl 线的顶点时==>删除 / 否==>增加顶点!!!")
    
15.   (while
    
16.     (setq pt (getpoint "\n自动识别增&删--取点/enter-退出:")) ;enter--重新选择pl线
    
17.     (setq entl (entget ent))
    
18.     (setvar "modemacro" "")
    
19.     (if
    
20.        (and (setq ptend (osnap pt "_end"))
    
21.             (member (cons 10 (list (car ptend)(cadr ptend))) entl)
    
22.        )
    
23.         (if (equal pt ptend)
    
24.           (eplv);删除顶点
    
25.           (aplv);增加顶点
    
26.         )
    
27.     );endif
    
28.   ); end while
    
29.   (setvar "osmode" os)
    
30.   (princ)
    
31. )
    
32. ;;;;删除顶点
    
33. (defun eplv ( / ptl entl2)
    
34.   (princ "\nok")
    
35.   (setq        ptl (cons 10 (list (car pt) (cadr pt) ));点对
    
36.         entl2 '()
    
37.   )
    
38.   (foreach n entl
    
39.     (if        (not(equal n ptl))
    
40.         (setq entl2 (cons n entl2))
    
41.     )
    
42.   )
    
43.   (setq entl (reverse entl2))
    
44.   (entmod entl)
    
45. )
    
46. ;;;;增加顶点
    
47. (defun aplv ()
    
48.   (initget 129)
    
49.   (setq npt (getpoint pt "\n 新的定位点/X-不做变动/<enter--原选择点>:"))
    
50.   (if
    
51.     (= (type pt) 'LIST)
    
52.     (progn
    
53.       (print "\nok")
    
54.       (command "_.break" ent pt "@" ^c
    
55.              "_.pedit" ent "j" (entlast) "" ^c
    
56.       );  打断
    
57.       (print "\n brk")
    
58.       (while (= (type npt) 'LIST)            ;新的定位点
    
59.           (print "enter")
    
60.           (setq entl (entget ent) ; 更新
    
61.                 ptl (cons 10 (list (car pt)(cadr pt)))
    
62.                 nptl (cons 10 (list (car npt)(cadr npt)))
    
63.                 entl2 '())
    
64.           (foreach n entl
    
65.             (if (equal n ptl)
    
66.                 (setq entl2 (cons nptl entl2))
    
67.                 (setq entl2 (cons n entl2))
    
68.             )
    
69.           )  ;  表项替换
    
70.           (setq entl (reverse entl2)
    
71.                 npt nil)
    
72.           (entmod entl)
    
73.       );  end while
    
74.     );  end progn
    
75.   );  end cond
    
76. )
    

<br /> (defun c:plve ( / os en entl pt ptend)<br />   (princ "\n plve====lwpolyline vert edit,增加/删除pl线顶点--vb1.0--------lxx.2001.7")<br />   (setvar "modemacro" "plve.多义线顶点增删程序--梁雄啸.2001")<br />   (setvar "cmdecho" 0)<br />   (setvar "osmode" 551)<br />   (princ "\n当取点为 pl 线的顶点时---删除/否---增加顶点")<br />   (setq        os   (getvar "osmode")<br />         en   (entsel "\n选择要增/删顶点的多义线:")<br />         ent  (car en)<br />   )<br />   (initget 128)<br />   (princ "\n!!!取点为 pl 线的顶点时==>删除 / 否==>增加顶点!!!")<br />   (while<br />     (setq pt (getpoint "\n自动识别增&删--取点/enter-退出:")) ;enter--重新选择pl线<br />     (setq entl (entget ent))<br />     (setvar "modemacro" "")<br />     (if<br />        (and (setq ptend (osnap pt "_end"))<br />             (member (cons 10 (list (car ptend)(cadr ptend))) entl)<br />        )<br />         (if (equal pt ptend)<br />           (eplv);删除顶点<br />           (aplv);增加顶点<br />         )<br />     );endif<br />   ); end while<br />   (setvar "osmode" os)<br />   (princ)<br /> )<br /> ;;;;删除顶点<br /> (defun eplv ( / ptl entl2)<br />   (princ "\nok")<br />   (setq        ptl (cons 10 (list (car pt) (cadr pt) ));点对<br />         entl2 '()<br />   )<br />   (foreach n entl<br />     (if        (not(equal n ptl))<br />         (setq entl2 (cons n entl2))<br />     )<br />   )<br />   (setq entl (reverse entl2))<br />   (entmod entl)<br /> )<br /> ;;;;增加顶点<br /> (defun aplv ()<br />   (initget 129)<br />   (setq npt (getpoint pt "\n 新的定位点/X-不做变动/<enter--原选择点>:"))<br />   (if<br />     (= (type pt) 'LIST)<br />     (progn<br />       (print "\nok")<br />       (command "_.break" ent pt "@" ^c<br />              "_.pedit" ent "j" (entlast) "" ^c<br />       );  打断<br />       (print "\n brk")<br />       (while (= (type npt) 'LIST)            ;新的定位点<br />           (print "enter")<br />           (setq entl (entget ent) ; 更新<br />                 ptl (cons 10 (list (car pt)(cadr pt)))<br />                 nptl (cons 10 (list (car npt)(cadr npt)))<br />                 entl2 '())<br />           (foreach n entl<br />             (if (equal n ptl)<br />                 (setq entl2 (cons nptl entl2))<br />                 (setq entl2 (cons n entl2))<br />             )<br />           )  ;  表项替换<br />           (setq entl (reverse entl2)<br />                 npt nil)<br />           (entmod entl)<br />       );  end while<br />     );  end progn<br />   );  end cond<br /> )<br />

梦断江南

文件打包：）

bluesky1000

找了半天，真是好程序呀，怎么没人顶呢？

lsjjm

最初由 梦断江南 发布
[B]]：增加、删除pl多义线顶点... [/B]

多意义线增删顶点的程序(纯LISP的, VLISP的) 本论坛已有贴出, 不知斑竹这个程序有什么新招?

hust_laohu

嘿
我正在找这个东西呢
不过这个好像不是我想要的 ,
不知道有没有可以选择保留自己想要的定点数目的lisp程序

梦断江南

最初由 lsjjm 发布
[B]
多意义线增删顶点的程序(纯LISP的, VLISP的) 本论坛已有贴出, 不知斑竹这个程序有什么新招? [/B]

没有什么新招，只不过这个是2002年的帖子（2001年的程序），那时候可能还没有你说的那些帖子，至少大部分没有。
现在重写的话，代码会少很多，人总是要进步的嘛，呵呵

yjtdkj

我不太理解多义线顶点 的作用，烦请斑竹讲解一下好吗？

andyhua5240

斑竹，能不能说一下这个程序的实际用处呀？不太明白它的实用性在哪个方面！谢谢！

梦断江南

如果你想不到用在什么地方，那说明你用不上，论坛上有很多程序，针对的应用方向也不尽相同，并不是每一个程序对个人都是有用的，大家各取所需吧。

lsjjm

最初由 hust_laohu 发布
[B]嘿,我正在找这个东西呢,不过这个好像不是我想要的...[/B]

你的具体要求是什么? "保留自己想要的定点数目" 是什么意思? 还是顶点的序号?

xxxyzxx

楼主在吗？工具很好，但是不能自动删点，对于快速制图仍是困难，能否作到自动删点呢？

li809

有源码公布为何要收币

ttthhh_hb

我还以为那个二楼的附件和一楼的源码有不同之处，结果是一样的。白白浪费一个爱心币。

yangkerjkl

多谢楼主提供!

ttthhh_hb

增加多义线顶点，可不必打断再join
http://www.xdcad.net/forum/showthread.php?s=&threadid=507850