[多段线]动态多段线加点

222808

最近工作中需要给多段线加顶点，在网上收集到一个非常简洁的代码
大佬原地址http://bbs.xdcad.net/thread-626400-1-1.html

kucha007

心血来潮改了一下,支持重多段线，支持已有点减点。弧段还有点问题

1. (defun C:AD (/ *error* K:DivLst4N K:AddRduPT4PLine en)
   
2.     (progn ;基础函数
   
3.       (defun *error* (x) ;出错函数
   
4.         (sssetfirst nil nil);取消选择集亮显
   
5.       )
   
6.       ;将表拆分为两个表list 前N项 剩下的项)
   
7.       (Defun K:DivLst4N (Lst N / LstN)
   
8.           (repeat N
   
9.               (setq LstN (cons (car Lst) LstN))
   
10.               (setq Lst (cdr Lst))
    
11.           )
    
12.           (list (reverse LstN) Lst)
    
13.       )
    
14.       ;多段线加减点
    
15.       (defun K:AddRduPT4PLine (en / Base IsClsd VxtNum VxtLst PT TgtPT Index Num)
    
16.         (if
    
17.           (and
    
18.               (setq obj (vlax-ename->vla-object en))
    
19.               (or
    
20.                 (and
    
21.                   (eq (vlax-get obj "ObjectName") "AcDbPolyline");轻多段线
    
22.                   (setq Base 2);XY
    
23.                 )
    
24.                 (and
    
25.                   (eq (vlax-get obj "ObjectName") "AcDb2dPolyline");重多段线
    
26.                   (setq Base 3);XYZ
    
27.                 )
    
28.               )
    
29.               (setq IsClsd (vlax-curve-isClosed obj);是否闭合
    
30.                     VxtNum (vlax-curve-getEndParam obj);终点参数
    
31.                     VxtLst (vlax-get obj "Coordinates");多段线顶点坐标(不含Z)
    
32.               )
    
33.           )
    
34.           (progn
    
35.               (sssetfirst nil (ssadd en));亮显对象
    
36.               (while (setq PT (getpoint "\n→请指定目标点:"))
    
37.                   (setq PT    (trans PT 1 0);转为WCS坐标
    
38.                         TgtPT (vlax-curve-getClosestPointTo obj PT);曲线上的最近点
    
39.                         Index (vlax-curve-getParamAtPoint obj TgtPT);最近点的位置
    
40.                   )
    
41.                   (if (not (eq Index (fix Index)));目标点在线上不存在
    
42.                       (progn
    
43.                           (setq Num  (* Base (1+ (fix Index)))) ;点的位置
    
44.                           (if (eq Base 2)
    
45.                               (setq PT (reverse (cdr (reverse PT))));去掉Z值
    
46.                           )
    
47.                           (setq VxtLst (K:DivLst4N VxtLst Num)
    
48.                                 VxtLst (append (car VxtLst) PT (cadr VxtLst))
    
49.                           )
    
50.                           (if (not (vl-catch-all-apply  'vlax-put (list obj "Coordinates" VxtLst)) )
    
51.                               (princ "\n——★★★ 成功：已添加所选点到多段线上! ★★★——")
    
52.                           )
    
53.                           (vla-Update obj);更新对象
    
54.                       )
    
55.                       (if
    
56.                         (and
    
57.                           (equal PT TgtPT 0.01);目标点在线上
    
58.                           (or
    
59.                               (and
    
60.                                   IsClsd ;闭合
    
61.                                   (>  (length VxtLst) (* Base 3));不少于三个点
    
62.                               )
    
63.                               (and
    
64.                                   (not IsClsd) ;不闭合
    
65.                                   (>  (length VxtLst) (* Base 2));不少于两个点
    
66.                               )
    
67.                           )
    
68.                         )
    
69.                         (progn
    
70.                             (setq Num (* Base (fix Index)))
    
71.                             (setq VxtLst (K:DivLst4N VxtLst Num)
    
72.                                   VxtLst (append (car VxtLst) (if (eq 2 Base)(cddr (cadr VxtLst))(cdddr (cadr VxtLst))))
    
73.                             )
    
74.                             (if (not (vl-catch-all-apply  'vlax-put (list obj "Coordinates" VxtLst)) )
    
75.                                 (princ "\n——★★★ 成功：已移除在线上的所选点! ★★★——")
    
76.                             )
    
77.                             (vla-Update obj);更新对象
    
78.                         )
    
79.                         (princ "\n——★★★ 失败：多段线无法再减点! ★★★——")
    
80.                       )
    
81.                   )
    
82.               )
    
83.               (sssetfirst nil);取消对象亮显
    
84.           )
    
85.         )
    
86.       )
    
87.     )
    
88.     (if (last (ssgetfirst))(sssetfirst nil nil));非空选取消选择集亮显
    
89.     (while
    
90.       (not
    
91.         (and
    
92.           (setq en (car (entsel "\n→请点选多段线:")))
    
93.           (wcmatch (Cdr (Assoc 0 (Entget en))) "*POLYLINE") ;多段线
    
94.         )
    
95.       )
    
96.       (princ "\n——★★★ 失败：请点选多段线! ★★★——")
    
97.     );选择多段线
    
98.     (K:AddRduPT4PLine en)
    
99.     (princ)
    
100. )
     

(defun C:AD (/ *error* K:DivLst4N K:AddRduPT4PLine en)<br />     (progn ;基础函数<br />       (defun *error* (x) ;出错函数<br />         (sssetfirst nil nil);取消选择集亮显<br />       )<br />       ;将表拆分为两个表<img src="static/image/smiley/default/sad.gif" smilieid="2" border="0" alt="" />list 前N项 剩下的项)<br />       (Defun K:DivLst4N (Lst N / LstN) <br />           (repeat N<br />               (setq LstN (cons (car Lst) LstN))<br />               (setq Lst (cdr Lst))<br />           )<br />           (list (reverse LstN) Lst)<br />       )<br />       ;多段线加减点<br />       (defun K:AddRduPT4PLine (en / Base IsClsd VxtNum VxtLst PT TgtPT Index Num)<br />         (if<br />           (and<br />               (setq obj (vlax-ename->vla-object en))<br />               (or<br />                 (and<br />                   (eq (vlax-get obj "ObjectName") "AcDbPolyline");轻多段线<br />                   (setq Base 2);XY<br />                 )<br />                 (and<br />                   (eq (vlax-get obj "ObjectName") "AcDb2dPolyline");重多段线<br />                   (setq Base 3);XYZ<br />                 )<br />               )<br />               (setq IsClsd (vlax-curve-isClosed obj);是否闭合<br />                     VxtNum (vlax-curve-getEndParam obj);终点参数<br />                     VxtLst (vlax-get obj "Coordinates");多段线顶点坐标(不含Z)<br />               )<br />           )<br />           (progn<br />               (sssetfirst nil (ssadd en));亮显对象<br />               (while (setq PT (getpoint "\n→请指定目标点:"))<br />                   (setq PT    (trans PT 1 0);转为WCS坐标<br />                         TgtPT (vlax-curve-getClosestPointTo obj PT);曲线上的最近点<br />                         Index (vlax-curve-getParamAtPoint obj TgtPT);最近点的位置<br />                   )<br />                   (if (not (eq Index (fix Index)));目标点在线上不存在<br />                       (progn<br />                           (setq Num  (* Base (1+ (fix Index)))) ;点的位置<br />                           (if (eq Base 2)<br />                               (setq PT (reverse (cdr (reverse PT))));去掉Z值<br />                           )<br />                           (setq VxtLst (K:DivLst4N VxtLst Num)<br />                                 VxtLst (append (car VxtLst) PT (cadr VxtLst))<br />                           )<br />                           (if (not (vl-catch-all-apply  'vlax-put (list obj "Coordinates" VxtLst)) )<br />                               (princ "\n——★★★ 成功：已添加所选点到多段线上! ★★★——")<br />                           )<br />                           (vla-Update obj);更新对象<br />                       )<br />                       (if <br />                         (and<br />                           (equal PT TgtPT 0.01);目标点在线上<br />                           (or<br />                               (and<br />                                   IsClsd ;闭合<br />                                   (>  (length VxtLst) (* Base 3));不少于三个点<br />                               )<br />                               (and<br />                                   (not IsClsd) ;不闭合<br />                                   (>  (length VxtLst) (* Base 2));不少于两个点<br />                               )<br />                           )<br />                         )<br />                         (progn<br />                             (setq Num (* Base (fix Index)))<br />                             (setq VxtLst (K:DivLst4N VxtLst Num)<br />                                   VxtLst (append (car VxtLst) (if (eq 2 Base)(cddr (cadr VxtLst))(cdddr (cadr VxtLst))))<br />                             )<br />                             (if (not (vl-catch-all-apply  'vlax-put (list obj "Coordinates" VxtLst)) )<br />                                 (princ "\n——★★★ 成功：已移除在线上的所选点! ★★★——")<br />                             )<br />                             (vla-Update obj);更新对象<br />                         )<br />                         (princ "\n——★★★ 失败：多段线无法再减点! ★★★——")<br />                       )<br />                   )<br />               )<br />               (sssetfirst nil);取消对象亮显<br />           )<br />         )<br />       )<br />     )<br />     (if (last (ssgetfirst))(sssetfirst nil nil));非空选取消选择集亮显<br />     (while <br />       (not <br />         (and <br />           (setq en (car (entsel "\n→请点选多段线:")))<br />           (wcmatch (Cdr (Assoc 0 (Entget en))) "*POLYLINE") ;多段线<br />         )<br />       )<br />       (princ "\n——★★★ 失败：请点选多段线! ★★★——")<br />     );选择多段线<br />     (K:AddRduPT4PLine en)<br />     (princ)<br /> )<br />

yanchao316

谢谢两位大佬的工具。各有特色。还发现一个不同点，楼主的在线外加点是指定加在哪段线上，需要每次选择，每次操作多一次但是能完全按照自己的要求，kucha007 的在线外加点是对最近的那段线加点，简单智能，但有可能加的那段并不是想加的那段。拿个矩形来测试容易发现。

jkop

常常会用到加点的，感谢分享，收藏先！

222808

kucha007 发表于 2023-11-30 17:37
心血来潮改了一下

我这个可以加点并且挪动位置，老师您这个是只能在线上加点

kucha007

222808 发表于 2023-12-1 09:06
我这个可以加点并且挪动位置，老师您这个是只能在线上加点

你那个也不能挪吧？

222808

kucha007 发表于 2023-12-1 09:17
你那个也不能挪吧？

我这个是可以的，只是说他不亮显，您可以加载试一下，我这边使用时可以把添加的点选择位置。您那个添加的点只能在线上。

aws

具体使用的场景？

222808

aws 发表于 2023-12-1 09:37
具体使用的场景？

就是方便加点并挪动位置，就是高版本自带的添加顶点

kucha007

222808 发表于 2023-12-1 09:22
我这个是可以的，只是说他不亮显，您可以加载试一下，我这边使用时可以把添加的点选择位置。您那个添加的 ...

更新了，可以再试试.支持加减点，支持轻重多段线

222808

kucha007 发表于 2023-12-1 10:22
更新了，可以再试试.支持加减点，支持轻重多段线

CAD2016使用您更新后的代码，只提示“请选择多段线”，但后续就没有了。