(VisualLISP版本)多段线增删顶点(支持弧段)

gzxl · 发表于 2025-8-13 11:43:53

本帖最后由 gzxl 于 2025-8-16 15:15 编辑

好多年没写过 lisp，最近闲，重试写下lisp（照着 ObjectARX版翻译）。可能代码有些繁琐。

(VisualLISP版本)多段线增删顶点(支持弧段)
添加顶点方式选项: 拾取点 or 两节点间按指定距离
添加顶点的多段线子段类型: 直线段 or 弧段 or 全部
起止点宽度未做处理

*** 增加顶点是在封闭多边形不改变面积情况下而编写的，之外的情况难免存在 bug ***

yjwht · 发表于 2025-8-13 13:44:57

已下载，抽空试一下

qazxswk · 发表于 2025-8-13 16:17:12

对楼主精通多种编写语言和研究精神表示钦佩。支持源码。不过此功能有个好用一点的代码，你可以参考一下。http://bbs.mjtd.com/thread-189001-1-1.html

gzxl · 发表于 2025-8-13 16:43:50

本帖最后由 gzxl 于 2025-8-14 04:16 编辑

哦，原来论坛已有，没写之前也搜了下没注意。

jierc · 发表于 2025-8-13 17:06:48

这个功能现在CAD好像自带了

llsheng_73 · 发表于 2025-8-14 12:54:35

gzxl 发表于 2025-8-13 16:43
哦，原来论坛已有，没写之前也搜了下没注意。

管它有没有，我也把这两天折腾的贴出来

(vl-load-com)
(defun bulgecentre(p1 p2 b);;计算弧段(子段凸度值非0)圆心,这个函数是抄的
(polar p1(+ (angle p1 p2) (-(/ pi 2)(* 2 (atAn b))))(/ (*(distance p1 p2) (1+ (* b b))) 4 b))
)
(defun cenab2bulg(cen a b / l s);;根据弧段圆心及起止点计算凸度值
(setq s(if(MINUSP(car(trans(mapcar'- a cen)0(mapcar'- a b))))-1 1))
(setq l(trans(mapcar'- cen b)0(mapcar'- cen a))
l(*(angle'(0 0)(list(last l)(car l)))0.25)
l(if(MINUSP s)(-(* 0.5 pi)l)l))
(/(sin l)(cos l)s))
(defun curvelengthof(e a b);;曲线e上两点间曲线距离(对于跨越闭合多段线起点的情况不适合，不过对本程序不影响，未进一步完善)
(-(vlax-curve-getdistatparam e(min(vlax-curve-getendparam e)b))(vlax-curve-getdistatparam e(max(vlax-curve-getstartparam e)a))))
(defun partof(e p / i n closed a b);;返回多段线e指定点所在子段详细情况(起点宽度止点宽度凸度(起点param 起点坐标)(p点param p)(止点param 止点坐标)
(or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
(setq i(vlax-curve-getparamatpoint e(vlax-curve-getclosestpointto e p))
n(1-(vlax-curve-getendparam e))closed(vlax-get-property e 'closed))
(vlax-invoke-method e 'GetWidth(fix i)'a 'b)
(vl-list* a b(vlax-invoke-method e 'GetBulge(fix i))
(mapcar(function(lambda(x / p)
(if(setq p(vlax-curve-getPointAtParam e x))(List x p))))(List(fix i)i(1+(fix i))))))
(defun delver(e i / arr arr1 i n i1 i2 n1 n2);|;;lw线上删点，处理凸度、起止宽度(本来想法是可以支持各种多段线的，但根据测试，通过PE命令曲线化得到的
二维多段线，无法获取、设置起止宽度getwidth、setwidth失效，vlax-invoke-method调用出错，vlax-invoke调用无反应),最终放弃了二维/三维多段线的处理|;
(and(or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
(=(vlax-get-property e'objectname)"AcDbPolyline")
(progn
(setq arr(vlax-safearray->list(vlax-variant-value(vlax-get-property e 'Coordinates)))
l(1-(/(length arr)2))
arr1(vlax-make-safearray 5(cons 0(+ l l -1)))
i1 -1 i2 -1 n1(+ i i)n2(1+ n1))
(vl-every(function(lambda(x)
(if(<= n1(setq i1(1+ i1)i2(1+ i2))n2)
(setq i1(1- i1))
(vlax-safearray-put-element arr1 i1 x))))arr)
(setq n1 i)
(if(< 0 i l)
(progn(or(zerop(setq b1(vlax-invoke-method e'getbulge(1- i))))
(zerop(setq b2(vlax-invoke-method e'getbulge i)))
(not(equal(setq cen(bulgecentre(vlax-curve-getpointatparam e(1- i))(vlax-curve-getpointatparam e i)b1))
(bulgecentre(vlax-curve-getpointatparam e i)(vlax-curve-getpointatparam e(1+ i))b2)1e-8))
(vlax-invoke-method e 'setbulge(1- i)(cenab2bulg cen(vlax-curve-getpointatparam e(1- i))(vlax-curve-getpointatparam e(1+ i)))))
(vlax-invoke-method e'getwidth(1- i)'i1 'i2)
(vlax-invoke-method e'getwidth i'i2 'i2)
(vlax-invoke-method e'setwidth(1- i)i1 i2)
t)t)
(while(< n1 l)(vlax-invoke-method e'setbulge n1(vlax-invoke-method e'getbulge(1+ n1)))(setq n1(1+ n1)))
(setq i(1+ i))
(while(<= i l)
(vlax-invoke-method e'getwidth i'i1 'i2)
(vlax-invoke-method e'setwidth(1- i)i1 i2)
(setq i(1+ i)))
(vlax-put-property e 'Coordinates arr1)))
)
(defun mADDVERTEX(e p / i a n);;;加点，因为调用ADDVERTEX方法，它会自动处理后续点、子段的凸度及起止宽度，但对于所增加点需要根据情况重新计算该点前后两个子段的凸度及起止底宽
(setq a(partof e p)i(car(nth 4 a))n(if(> i 0)(1+(fix i))i))
(vlax-invoke e'ADDVERTEX n(2dp p))
(vl-every(function(lambda(x y)(set x(cadr y))))'(p1 p p2)(cdddr a))
(if(and(apply'and a)(< 0 i(1-(vlax-curve-getendparam e))))
(progn
(if(< 0(+(car a)(cadr a)))
(progn(setq kd(+(car a)(*(/(-(cadr a)(car a))(curvelengthof e(car(nth 3 a))(car(last a))))(curvelengthof e(car(nth 3 a))(car(nth 4 a))))))
(vlax-invoke-method e 'setwidth(1- n)(car a)kd)
(vlax-invoke-method e 'setwidth n kd(cadr a))))
(or(zerop(caddr a))
(vl-some(function(lambda(a b)
(VL-CATCH-ALL-APPLY(function vlax-invoke-method)(list e'setbulge a b))))
(List(1- n)n)
(setq cen(bulgecentre p1 p2(caddr a))
bulg(list(cenab2bulg cen p1 p)(cenab2bulg cen p p2))))))))
(defun 2dp(pt)(mapcar'+'(0 0)pt))
(defun C:y(/ e p a q i);|;;mADDVERTEX和delVERTEX函数示例，完败CASS的加点命令Y，
其它处理方式需要自动解决，处理好数据后调用mADDVERTEX和delVERTEX，想要一次性批量处理一系列点，还需要改写这两个函数|;
(if(and(setq e(car(entsel"\n选择要多线段")))
(sssetfirst nil(ssadd e))
(setq e(vlax-ename->vla-object e))
(=(vlax-get-property e'objectname)"AcDbPolyline"))
(while(setq P(getpoint "\r指定删除点或新顶点: "))
(if(and(=(fix(setq P(trans P 1 0)q(vlax-curve-getclosestpointto e p)
a(vlax-curve-getparamatpoint e q)))a)
(equal(2DP p)(2DP q)1e-5)
(>(vlax-curve-getendparam e)1))
(delver e(vlax-curve-getParamAtPoint e p))
(mADDVERTEX e p))
(vlax-invoke-method e 'Update))
)
(sssetfirst nil))

(vl-load-com) 
(defun bulgecentre(p1 p2 b);;计算弧段(子段凸度值非0)圆心,这个函数是抄的 
  (polar p1(+ (angle p1 p2) (-(/ pi 2)(* 2 (atAn b))))(/ (*(distance p1 p2) (1+ (* b b))) 4 b)) 
  ) 
(defun cenab2bulg(cen a b / l s);;根据弧段圆心及起止点计算凸度值 
  (setq s(if(MINUSP(car(trans(mapcar'- a cen)0(mapcar'- a b))))-1 1)) 
  (setq l(trans(mapcar'- cen b)0(mapcar'- cen a)) 
  l(*(angle'(0 0)(list(last l)(car l)))0.25) 
  l(if(MINUSP s)(-(* 0.5 pi)l)l)) 
  (/(sin l)(cos l)s)) 
(defun curvelengthof(e a b);;曲线e上两点间曲线距离(对于跨越闭合多段线起点的情况不适合，不过对本程序不影响，未进一步完善) 
  (-(vlax-curve-getdistatparam e(min(vlax-curve-getendparam e)b))(vlax-curve-getdistatparam e(max(vlax-curve-getstartparam e)a)))) 
(defun partof(e p / i n closed a b);;返回多段线e指定点所在子段详细情况(起点宽度 止点宽度 凸度(起点param 起点坐标)(p点param p)(止点param 止点坐标) 
  (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e))) 
  (setq i(vlax-curve-getparamatpoint e(vlax-curve-getclosestpointto e p)) 
  n(1-(vlax-curve-getendparam e))closed(vlax-get-property e 'closed)) 
  (vlax-invoke-method e 'GetWidth(fix i)'a 'b) 
  (vl-list* a b(vlax-invoke-method e 'GetBulge(fix i)) 
      (mapcar(function(lambda(x / p) 
            (if(setq p(vlax-curve-getPointAtParam e x))(List x p))))(List(fix i)i(1+(fix i)))))) 
(defun delver(e i / arr arr1 i n i1 i2 n1 n2);|;;lw线上删点，处理凸度、起止宽度(本来想法是可以支持各种多段线的，但根据测试，通过PE命令曲线化得到的 
二维多段线，无法获取、设置起止宽度getwidth、setwidth失效，vlax-invoke-method调用出错，vlax-invoke调用无反应),最终放弃了二维/三维多段线的处理|; 
  (and(or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e))) 
      (=(vlax-get-property e'objectname)"AcDbPolyline") 
      (progn 
  (setq arr(vlax-safearray->list(vlax-variant-value(vlax-get-property e 'Coordinates))) 
        l(1-(/(length arr)2)) 
        arr1(vlax-make-safearray 5(cons 0(+ l l -1))) 
        i1 -1 i2 -1 n1(+ i i)n2(1+ n1)) 
  (vl-every(function(lambda(x) 
          (if(<= n1(setq i1(1+ i1)i2(1+ i2))n2) 
            (setq i1(1- i1)) 
            (vlax-safearray-put-element arr1 i1 x))))arr) 
  (setq n1 i) 
  (if(< 0 i l) 
    (progn(or(zerop(setq b1(vlax-invoke-method e'getbulge(1- i)))) 
       (zerop(setq b2(vlax-invoke-method e'getbulge i))) 
       (not(equal(setq cen(bulgecentre(vlax-curve-getpointatparam e(1- i))(vlax-curve-getpointatparam e i)b1)) 
           (bulgecentre(vlax-curve-getpointatparam e i)(vlax-curve-getpointatparam e(1+ i))b2)1e-8)) 
       (vlax-invoke-method e 'setbulge(1- i)(cenab2bulg cen(vlax-curve-getpointatparam e(1- i))(vlax-curve-getpointatparam e(1+ i))))) 
      (vlax-invoke-method e'getwidth(1- i)'i1 'i2) 
      (vlax-invoke-method e'getwidth i'i2 'i2) 
      (vlax-invoke-method e'setwidth(1- i)i1 i2) 
      t)t) 
  (while(< n1 l)(vlax-invoke-method e'setbulge n1(vlax-invoke-method e'getbulge(1+ n1)))(setq n1(1+ n1))) 
  (setq i(1+ i)) 
  (while(<= i l) 
    (vlax-invoke-method e'getwidth i'i1 'i2) 
    (vlax-invoke-method e'setwidth(1- i)i1 i2) 
    (setq i(1+ i))) 
  (vlax-put-property e 'Coordinates arr1))) 
  ) 
(defun mADDVERTEX(e p / i a n);;;加点，因为调用ADDVERTEX方法，它会自动处理后续点、子段的凸度及起止宽度，但对于所增加点需要根据情况重新计算该点前后两个子段的凸度及起止底宽 
  (setq a(partof e p)i(car(nth 4 a))n(if(> i 0)(1+(fix i))i)) 
  (vlax-invoke e'ADDVERTEX n(2dp p)) 
  (vl-every(function(lambda(x y)(set x(cadr y))))'(p1 p p2)(cdddr a)) 
  (if(and(apply'and a)(< 0 i(1-(vlax-curve-getendparam e)))) 
    (progn 
      (if(< 0(+(car a)(cadr a))) 
  (progn(setq kd(+(car a)(*(/(-(cadr a)(car a))(curvelengthof e(car(nth 3 a))(car(last a))))(curvelengthof e(car(nth 3 a))(car(nth 4 a)))))) 
    (vlax-invoke-method e 'setwidth(1- n)(car a)kd) 
    (vlax-invoke-method e 'setwidth n kd(cadr a)))) 
      (or(zerop(caddr a)) 
   (vl-some(function(lambda(a b) 
          (VL-CATCH-ALL-APPLY(function vlax-invoke-method)(list e'setbulge a b)))) 
     (List(1- n)n) 
     (setq cen(bulgecentre p1 p2(caddr a)) 
           bulg(list(cenab2bulg cen p1 p)(cenab2bulg cen p p2)))))))) 
(defun 2dp(pt)(mapcar'+'(0 0)pt)) 
(defun C:y(/ e p a q i);|;;mADDVERTEX和delVERTEX函数示例，完败CASS的加点命令Y， 
其它处理方式需要自动解决，处理好数据后调用mADDVERTEX和delVERTEX，想要一次性批量处理一系列点，还需要改写这两个函数|; 
  (if(and(setq e(car(entsel"\n选择要多线段"))) 
   (sssetfirst nil(ssadd e)) 
   (setq e(vlax-ename->vla-object e)) 
   (=(vlax-get-property e'objectname)"AcDbPolyline")) 
    (while(setq P(getpoint "\r指定删除点或新顶点: ")) 
      (if(and(=(fix(setq P(trans P 1 0)q(vlax-curve-getclosestpointto e p) 
       a(vlax-curve-getparamatpoint e q)))a) 
       (equal(2DP p)(2DP q)1e-5) 
       (>(vlax-curve-getendparam e)1)) 
  (delver e(vlax-curve-getParamAtPoint e p)) 
  (mADDVERTEX e p)) 
      (vlax-invoke-method e 'Update)) 
    ) 
  (sssetfirst nil))

gzxl · 发表于 2025-8-14 13:39:15

llsheng_73 发表于 2025-8-14 12:54
管它有没有，我也把这两天折腾的贴出来

我折腾了三天以上，不记得几天了，三天是肯定的。

bskidtf · 发表于 2025-8-14 13:44:50

保持宽度不变的增点，我也折腾过，源码放在仓库里发霉了都，

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

[源码] (VisualLISP版本)多段线增删顶点(支持弧段)

本帖子中包含更多资源

评分

点评

点评

本帖子中包含更多资源

评分

评分