多段线pline添加及删除（批量）顶点源码分享

chenyizhen28 发表于 2024-8-2 17:32:53

以下是我写的多段线添加顶点，删除顶点代码（支持批量删除），但有两个bug。
1、对于填充边界加减顶点后，填充不能跟随变动。
2、小比例图时加减点会失败。
处于添加模式时，线会被改为红色，为删除模式时，线会被改为青色。
高手可以自行处理以上2个问题。(本人能力有限)

(defun stop ()
(while (> (getvar "CMDACTIVE") 0) (command PAUSE))
);end

(vl-load-com)
;;多线加减顶点
(defun C:dxdd (/ EN OBJ PT PP Alist ss-temp )
(setvar "cmdecho" 0)
(defun *ERROR* (msg) ;按ESC退出时执行
   ;(princ "\n按ESC退出。")
   (cond
;;有设置A也正常退出出错
((= dxdd-exit 100)
(progn
(princ "\n有设置A的,ESC正常退出。")
(setq color-n nil)
(setq dxdd-exit nil)
(stop)
;(command "SELECT" enname "")
;(command "change" (entlast) "" "p" "c" ss-color)
)
)

;;没有设置A的
((= color-n 0)
(progn
(command "change" enname "" "" "p" "c" ss-color "")
(stop)
(princ "\n没有设置A的,按ESC退出。")
(setq color-n nil)
);progn
)

;;有设置A的
((> color-n 0)
(progn
;;恢复颜色
;(princ (strcat "\n按esc重置次数:" (rtos color-n 2 0)))
(command "change" enname "" "" "p" "c" ss-color "")
(stop)
(princ "\n设置A的,按ESC退出。")
(setq color-n nil)
);progn
);
);cond
   (setvar "cmdecho" 0)
   (command "undo" "e")
   (setvar "cmdecho" 1)
   );error

(if (= color-n nil) (setq color-n 0))
(bz_o)
(if
(= dxdd nil)
(setq dxdd "add")
);if
;;用于切换时改为自动模式
(if
(= dxdd-auto nil)
(setq dxdd-auto "N")
);if
;;选对象提示
(if
(= dxdd "add")
(setq dxdd-alert "增加")
(setq dxdd-alert "批量删除")
)
;;加减点提示
(if
(= dxdd "add")
(setq dxdd-alert-n "批量删除")
(setq dxdd-alert-n "增加")
)
(if
(= dxdd-auto "N")
(progn
   (strcat "\n选择一条要" dxdd-alert "节点的多段线: ")
   (setq EN (ssget ":S"))
   (if EN
(progn
(command "undo" "be")
(princ "第一个")
;;第一次运行提取颜色
(if (= color-n 0)
(progn
(setq enname (ssname EN 0))
(setq ss-color (assoc 62 (entget enname)))
(if (= ss-color nil)
   (setq ss-color "bylayer")
   (setq ss-color (rtos (cdr ss-color) 2 0))
   )
);progn
);if

(if (= dxdd "add")
   (progn
      ;;(princ "第一个红")
      (command "change" enname "" "p" "c" "1" "")
   )
   (progn
      ;;(princ "第一个青")
      (command "change" enname "" "p" "c" "4" "")
   )
)
(stop)
(command "SELECT" enname "")
(sssetfirst nil (ssadd enname))
) ;progn
);if
) ;progn
(progn
   (command "undo" "be")
   ;;(princ "第二个")

   (command "SELECT" enname "")
   ;;第一次运行提取颜色
(if (= color-n 0)
(progn
(setq ss-color (assoc 62 (entget enname )))
(if (= ss-color nil)
   (setq ss-color "bylayer")
   (setq ss-color (rtos (cdr ss-color) 2 0))
   )
);progn
);if



   (if (= dxdd "add")
(progn
;;(princ "第二个红")
(command "SELECT" enname "")
(command "change" (ssget "p") "" "p" "c" "1" "")
)
(progn
;;(princ "第二个青")
(command "SELECT" enname "")
(command "change" (ssget "p") "" "p" "c" "4" "")
)
   )
(stop)

   ;(setq EN (entlast))
   (command "SELECT" enname "")
(sssetfirst nil (ssadd enname))

   (setq dxdd-auto "N")
) ;progn
) ;if

(if (and enname

      ;(sssetfirst nil (ssadd enname))
      (setq OBJ (vlax-ename->vla-object enname))
      (or (= (vla-get-objectname OBJ) "AcDbPolyline")
            (and (princ "\n所选的对象不是多段线。") nil)
      )
   )
(progn

(initget "A")

(if
   (= dxdd "add")
   (progn
;;加点的
(while
   (setq PT (getpoint (strcat"\n请点取要"dxdd-alert"的节点或["dxdd-alert-n"(A)]: ")))
   (cond
((= PT "A")
(progn
   (setq color-n (1+ color-n))
   (if
   (= dxdd "add")
      (setq dxdd "del")
      (setq dxdd "add")
   )
   (setq dxdd-auto "Y")

   (c:dxdd)
   ;(command "undo" "e")
   (exit)
);progn
);cond_A
;;自动识别增删
((/= PT nil)
(progn
(setq Alist (entget enname))
(setq PT (trans PT 1 0)
PP (vlax-curve-getclosestpointto OBJ PT);返回取得点在曲线上的最近点
)

(cond

   ;;减加顶点
   ((and (= dxdd "add")
   (or
   (< (distance pt (vlax-curve-getPointAtParam OBJ (fix (+ 1 (vlax-curve-getparamatpoint OBJ PP))))) 50)
   (< (distance pt (vlax-curve-getPointAtParam OBJ (fix (+ 0.5 (vlax-curve-getparamatpoint OBJ PP))))) 50)
   )
   )
      (progn
(princ (strcat "减顶点,两点距离:" (rtos (min
            (distance pt (vlax-curve-getPointAtParam OBJ (fix (+ 1 (vlax-curve-getparamatpoint OBJ PP)))))
            (distance pt (vlax-curve-getPointAtParam OBJ (fix (+ 0.5 (vlax-curve-getparamatpoint OBJ PP)))))
            )
            2 2)))
(setq pline-n (fix (+ 0.5 (vlax-curve-getparamatpoint OBJ PP))));;返回第N个顶点
(setq pt (vlax-curve-getpointatparam enname pline-n));;返回对应第N个顶点坐标,取消该条时，仅删除指定顶点。否则空选也删除。
(entmod (vl-remove (list 10 (car pt) (cadr pt)) Alist));;;移除表中该点表
);;progn
      )

   ;;增加顶点
   ((= dxdd "add")
      (progn
(princ "加顶点.")
(setq pline-n (fix (+ 1 (vlax-curve-getparamatpoint OBJ PP))));;返回第N个顶点
;;(vlax-curve-getPointAtParam OBJ pline-n);;返回对应点坐标
            (vlax-invoke OBJ 'ADDVERTEX pline-n (list (car PT) (cadr PT)));;;pline线加点
);;progn
      )


   ;;减加顶点
      ((/= dxdd "add")
      (progn
(princ "\n不等于ADD")
(setq pline-n (fix (+ 0.5 (vlax-curve-getparamatpoint OBJ PP))));;返回第N个顶点
(setq pt (vlax-curve-getpointatparam enname pline-n));;返回对应第N个顶点坐标,取消该条时，仅删除指定顶点。否则空选也删除。
(entmod (vl-remove (list 10 (car pt) (cadr pt)) Alist));;;移除表中该点表
);;progn
      )
   );;cond

);progn
);cond_/=nil
);cond

   (initget "A")
);while
);progn

   ;;批量删除点
   (progn
(while
   (setq PT (getpoint (strcat"\n请框选要删除的多段线顶点或["dxdd-alert-n"(A)]: ")))
   (cond
((= PT "A")
(progn
   (setq color-n (1+ color-n))
   (if
   (= dxdd "add")
      (setq dxdd "del")
      (setq dxdd "add")
   )
   (setq dxdd-auto "Y")

   (c:dxdd)
   ;(command "undo" "e")
   (exit)
);progn
);cond_A
((/= PT nil)
(progn

(setq p1 PT
p3 (getcorner p1 "\n指定对角点或:")
) ;选择框

(setq p1 (trans p1 1 0)
p3 (trans p3 1 0)
)

(if p3
   (progn
      (setq p1x (min (car p1) (car p3))
      p1y (min (cadr p1) (cadr p3))
      p3x (max (car p1) (car p3))
      p3y (max (cadr p1) (cadr p3))
      )
      ;(setq enname (ssname ss 0))
      (setq Alist (entget enname))
      (setq n 0) ;重复生成顶点次数
      (setq m (cdr (assoc 90 Alist))) ;重复操作次数
      ;;(setq OBJ (vlax-ename->vla-object enname))

      (repeat m ;重复执行，执行的次数等于所选对象的个数
(setq n (+ n 1))
(setq pt(vlax-curve-getpointatparam enname n)
      ptx (car pt)
      pty (cadr pt)
) ;获取坐标
(if (and
      (> ptx p1x)
      (< ptx p3x)
      (> pty p1y)
      (< pty p3y)
      )
   (setq Alist (vl-remove (list 10 (car pt) (cadr pt))
         Alist
         )
   )
) ;if

      ) ;repeat
      ;;移除表中该点表
      (entmod Alist)
   ) ;progn
) ;if

) ;progn
);cond_/=nil
);cond

   (initget "A")
);while
);progn
   );if

   ;;;通用代码

;(princ (strcat "\n重置次数:" (rtos color-n 2 0)))
(if (= color-n 0)
   ;;没有设置A的
   (progn
;;恢复颜色
(command "change" enname"" "" "p" "c" ss-color "")
(stop)
(princ "\n没有设置A的,正常退出。")

);progn
   (progn
(princ "\n设置A的,正常退出。")
;(princ (strcat "\n按esc重置次数:" (rtos color-n 2 0)))
;(princ (strcat "\n最后颜色系:" ss-color))
(command "change" enname "" "" "p" "c" ss-color "")
(stop)
(setq dxdd-exit 100)
;(princ (strcat "\n尾部结束重置次数:" (rtos color-n 2 0)))


   );progn
   );if


   (command "undo" "e")




);progn
);if
;(sssetfirst)
;;程序退出处理

(setvar "cmdecho" 1)
(princ)
);end

你有种再说一遍 发表于 2024-8-2 20:33:55

难道你想做拉伸填充?

kozmosovia 发表于 2024-8-2 21:07:15

夹点就能添加删除，还要自己造个蹩脚的轮子？

chenyizhen28 发表于 2024-8-2 22:12:25

你有种再说一遍发表于 2024-8-2 20:33
难道你想做拉伸填充?

不是，只是想改pline,有时候刚好pline是填充用的。就想着一起动。要不然修改后，得重新手填一次。

chenyizhen28 发表于 2024-8-2 22:14:54

kozmosovia 发表于 2024-8-2 21:07
夹点就能添加删除，还要自己造个蹩脚的轮子？

你试一下就知道那个好用，那个难用了。

MZ_li 发表于 2024-8-3 08:41:02

只要是源码，哪怕是个四边形的轮子我也赞，试错也是一种进步

yk1216 发表于 2024-8-31 15:37:10

谢谢楼主分享，下载收藏了

页: [1]

明经CAD社区's Archiver

多段线pline添加及删除（批量）顶点源码分享