多段线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

(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

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

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

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

本帖子中包含更多资源

评分