[多段线]动态多段线加点
最近工作中需要给多段线加顶点，在网上收集到一个非常简洁的代码大佬原地址http://bbs.xdcad.net/thread-626400-1-1.html
本帖最后由 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)
)
谢谢两位大佬的工具。各有特色。还发现一个不同点，楼主的在线外加点是指定加在哪段线上，需要每次选择，每次操作多一次但是能完全按照自己的要求，kucha007 的在线外加点是对最近的那段线加点，简单智能，但有可能加的那段并不是想加的那段。拿个矩形来测试容易发现。 常常会用到加点的，感谢分享，收藏先！ kucha007 发表于 2023-11-30 17:37
心血来潮改了一下
我这个可以加点并且挪动位置，老师您这个是只能在线上加点 222808 发表于 2023-12-1 09:06
我这个可以加点并且挪动位置，老师您这个是只能在线上加点
你那个也不能挪吧？ kucha007 发表于 2023-12-1 09:17
你那个也不能挪吧？
我这个是可以的，只是说他不亮显，您可以加载试一下，我这边使用时可以把添加的点选择位置。您那个添加的点只能在线上。
具体使用的场景？ aws 发表于 2023-12-1 09:37
具体使用的场景？
就是方便加点并挪动位置，就是高版本自带的添加顶点 222808 发表于 2023-12-1 09:22
我这个是可以的，只是说他不亮显，您可以加载试一下，我这边使用时可以把添加的点选择位置。您那个添加的 ...
更新了，可以再试试.支持加减点，支持轻重多段线 kucha007 发表于 2023-12-1 10:22
更新了，可以再试试.支持加减点，支持轻重多段线
CAD2016使用您更新后的代码，只提示“请选择多段线”，但后续就没有了。
页:
[1]
2