[LISP]绘制截断线的程序，请大家一起来完善！

walong

;测试打断图元的效果
;程序：王龙
;时间：2004年元月
;打断分析：通常一张图纸中有多个图形，而打断一个图元，与这个图元相联的其它图元也应随之向内移。
;所以这个小程序的难点就在于，如何很好的作到，相联图元移动，其它无关图元不能移动（如图纸框线）
;我通过建立多个图层，将不移动的图元放在某些图层上，并将这些图层锁定。
;我感觉这样来移动图元和控制某些图元不能称动的方法很被动，这样对建图时，就要很好控制好图层，否则肯定会出问题。
;以下代码没有对图层进行锁定控制。
(defun c:dd();pz py pd p1 p2 p3 p4 pa pb tg pt pt0 pt1 pt2
  ;(command "layer" "m" "a1" "")
  ;(command "layer" "m" "a2" "")
  ;(command "layer" "m" "a3" "")
  ;(command "layer" "m" "a4" "")
  ;(command "layer" "m" "a5" "")
  ;(command "layer" "m" "a6" "")
  (setvar "cmdecho" 0)
  (setq os (getvar "osmode"))   ;获取对像捕捉原设定值       
  (setvar "osmode" 0) ;关闭对像捕足

  ;按矩形进行修剪要打断的图元
  (PrinC "\n清除指定的矩形区...")
       (SetQ pz (GetPoint "\n左下角点: ") x0 (Car pz) y0 (Cadr pz)
             py (GetCorner pz "\n右上角点: ") x1 (Car py) y1 (Cadr py)
             pd (* 0.005 (Distance pz py))
             pww (- x1 x0)
       )
       ;(Command "zoom" "w" pz py)
       (SetQ p1 (List (+ x0 pd) (+ y0 pd))
             p2 (List (- x1 pd) (+ y0 pd))
             p3 (List (- x1 pd) (- y1 pd))
             p4 (List (+ x0 pd) (- y1 pd)) ;修剪用的围栏点
       )
       (SetQ pa (List (+ x0 pd pd) (+ y0 pd pd))
             pb (List (- x1 pd pd) (- y1 pd pd))
       )
       (Command "rectang" "f" 0 pz py) ;生成剪切边界框
       (SetQ tg (EntLast)) ;取出边界框对名
       (PrinC "\n开始")
       (SetVar "cmdecho" 0)
       (While (SSGet "c" pa pb) ;如果区域内还有图线...
         ;(setq ment (entget (ssname (SSGet "c" pa pb) 0)));为打断线提供点坐标作准备
         (Command "trim" tg "" "f" p1 p2 ""
                                    "f" p2 p1 ""
                                    "f" p2 p3 ""
                                    "f" p3 p2 ""
                                    "f" p3 p4 ""
                                    "f" p4 p3 ""
                                    "f" p4 p1 ""
                                    "f" p1 p4 ""
                                 ""  ;剪切
              )
              (EntDel tg)
              (Command "erase" "w" pz py "") ;删除中间的西
         ;(setq my0 (cadr (cdr (nth 18 ment))))
         ;(setq my1 (cadr (cdr (nth 22 ment))))
         ;(setq ml1 (list x0 (+ my0 10)));为画截断线找点
         ;(setq ml2 (list x0 (- my1 10)))
         ;(setq mr1 (list x1 (+ my0 10)))
         ;(setq mr2 (list x1 (- my1 10)))
         
         (setq ml1 (list x0 y0 ));为画截断线找点
         (setq ml2 (list x0 y1 ))
         (setq mr1 (list x1 y0 ))
         (setq mr2 (list x1 y1 ))
         
         (command "color" "r")
         (command "linetype" "s" "HANTOM2" "")
         (command "line" ml1 ml2 "")
         (command "line" mr1 mr2 "")
         (command "linetype" "s" "byl" "")
         (command "color" "byl")
         ;绘制出的截断线长度与开始画的矩形修剪框有关，如果矩形修剪框画的上下不对，
         ;截断线也会上下不对称，显得不好看，不知如何解决
         (PrinC ".")
       )
       (PrinC " 完成.")(SetVar "cmdecho" 1) (PrinC)
  
  ;以点为界分左右两边进行划分选集
  ;(setq pt (getpoint "\n选分界点:"))
  (setq pt pa)       
  (setq pt0 (list (car pt) -1e99 0))
  (setq pt1 '(-1e99 1e99 0))
  (setq pt2 '(1e99 1e99 0))
  (command ".zoom" "all")
  (setq        ss1 (ssget "w" pt0 pt1)
        ss2 (ssget "w" pt0 pt2))
  (command ".zoom" "p")
  ;(princ (strcat "左边有实体:" (itoa (sslength ss1)) "个,右边有实体:"(itoa (sslength ss2)) "个."))
  
  ;对图元进行移动
  (setq movepw (- pww 10))
  (command "move" ss1 "" '(0 0) (list movepw 0))
  (setvar "osmode" os) ;还原对像捕足

  (prin1)  
  )

walong

请大家一同来完善！

walong

顶

dubs01

在有没有选到的线是会进入死循环！