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

222808 · 发表于 2023-11-30 14:45

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

kucha007 · 发表于 2023-11-30 17:37

本帖最后由 kucha007 于 2023-12-1 10:21 编辑

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

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

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

yanchao316 · 发表于 2023-12-1 10:43

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

jkop · 发表于 2023-11-30 23:23

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

222808 · 发表于 2023-12-1 09:06

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

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

kucha007 · 发表于 2023-12-1 09:17

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

你那个也不能挪吧？

222808 · 发表于 2023-12-1 09:22

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

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

aws · 发表于 2023-12-1 09:37

具体使用的场景？

222808 · 发表于 2023-12-1 09:42

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

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

kucha007 · 发表于 2023-12-1 10:22

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

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

222808 · 发表于 2023-12-1 10:30

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

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

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

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

本帖子中包含更多资源

评分