[LISP函数]：实用的平面图修剪程序

furge

该程序能自动的在某范围内对平面图进行修剪，对分割平面图或删除平面图上的某一部分非常使用。

(defun c:cut ()
;;WWW: http://www.io.com/~bcjones
;;命令【SCB】, 将修剪和清除矩形框外部的所有实体，并保留边界。
;;命令【SC】, 将修剪和清除矩形框外部的所有实体，不保留边界。
;;命令【SCD】, 将修剪和清除矩形框内部的所有实体，不保留边界

;;Please feel free to rename these commands as you desire.
(defun c:scb () (section t nil)); SECTION W/ BORDER
(defun c:sc () (section nil nil)); SECTION W/O BORDER
(defun c:scd () (section nil t)); DELETE INSIDE RECTANGLE


* * * * * ERROR ROUTINE * * * * *
(defun newerr (msg)
(prompt (strcat "\n选择取消: " msg)); PRINT ERROR
(setvar "cmdecho" cmd); RESET COMMAND ECHO
(setvar "highlight" hlt); RESET HIGHLIGHT
)


* * * * * MAIN FUNCTION * * * * *
;If the first argument has any value other than nil then the border will be left.  If it is nil
;then the border is erased.
;If the second argument is has any value other than nil then entities inside the border will be erased.
;If it is nil then entities outside the border are erase.
;For very large area drawings (maps or something), the DST variable may need to be changed.  If you
;find that not all entities are being trimmed properly try increasing the number higher than 1000.

(defun section (bdr n / olderr newerr cmd hlt p1 p2 p1x p1y p2x p2y p3 p4 dst plus minus p1a p2a p3a p4a lst)
(graphscr); CHANGE TO GRAPHICS SCREEN
(setq olderr *error* ; SET UP NEW
       *error* newerr ; ERROR ROUTINE
       cmd (getvar "cmdecho"); SAVE COMMAND ECHO SETTING
       hlt (getvar "highlight"); SAVE HIGHLIGHT SETTING

       p1 (getpoint "\n选择矩形框的第一角: "); GET LL CORNER OF RECTANGLE
       p2 (getcorner p1 "\n选择另一角: "); GET UR CORNER
       ss (command "-osnap" "")
       p1x (car p1)
       p1y (cadr p1)
       p2x (car p2)
       p2y (cadr p2)
       p3 (list p2x p1y); BUILD LR CORNER
       p4 (list p1x p2y); BUILD UL CORNER
       dst (/ (distance p1 p2) 1000.0); OFFSET FACTOR FOR TRIMMING
       plus (if n - +)
       minus (if n + -)
);END SETQ
(cond
  ((and (< p1x p2x) (< p1y p2y)); P1 IS LL CORNER
   (setq p1a (list (minus p1x dst) (minus p1y dst)); BUILD LL TRIM LINE POINT
         p2a (list (plus p2x dst) (plus p2y dst))); BUILD UR TRIM LINE POINT
  )
  ((and (> p1x p2x) (< p1y p2y)); P1 IS UL CORNER
   (setq p1a (list (plus p1x dst) (minus p1y dst)); BUILD LL TRIM LINE POINT
         p2a (list (minus p2x dst) (plus p2y dst))); BUILD UR TRIM LINE POINT
  )
  ((and (> p1x p2x) (> p1y p2y)); P1 IS UR CORNER
   (setq p1a (list (plus p1x dst) (plus p1y dst)); BUILD LL TRIM LINE POINT
         p2a (list (minus p2x dst) (minus p2y dst))); BUILD UR TRIM LINE POINT
  )
  ((and (< p1x p2x) (> p1y p2y)); P1 IS LR CORNER
   (setq p1a (list (minus p1x dst) (plus p1y dst)); BUILD LL TRIM LINE POINT
         p2a (list (plus p2x dst) (minus p2y dst))); BUILD UR TRIM LINE POINT
  )
); END COND
(setq p3a (list (car p2a) (cadr p1a)); BUILD LR TRIM LINE POINT
       p4a (list (car p1a) (cadr p2a)); BUILD UL TRIM LINE POINT
); END SETQ
(setvar "cmdecho" 0); TURN OFF COMMAND ECHO
(setvar "highlight" 0); TURN OFF HIGHLIGHT
(command "_.pline" p1 p3 p2 p4 "_c"); DRAW POLYLINE BORDER
(setq lst (entlast)); SAVE POLYLINE ENTITY NAME
(if n                                          ;ERASE ENTITIES
  (command "_.erase" "_w" p1 p2 "_r" lst "")    ;INSIDE RECTANGLE
  (command "_.erase" "_all" "_r" "_c" p1 p2 "") ;OUTSIDE RECTANGLE
); END IF
(command "_.trim" lst "" "_f" p1a p3a ""     ;TRIM ENTITIES AROUND BORDER
                          "_f" p3a p2a ""     ;DO TO THE FINICKY NATURE OF TRIMMING
                          "_f" p2a p4a ""     ;WITH THE FENCE OPTION, I HAVE USED FOUR
                          "_f" p4a p1a "" ""  ;FENCE LINES INSTEAD OF ONE LONG ONE
); END COMMAND
(if (not bdr) (entdel lst)); DELETE POLYLINE BORDER IF DESIRED
(setq *error* olderr); RESTORE ORIGINAL ERROR ROUTINE
(setvar "highlight" hlt); RESTORE HIGHLIGHT
(setvar "cmdecho" cmd); RESTORE COMMAND ECHO
(princ); EXIT CLEANLY
)
;;The following prompts are disabled when section.lsp is used with dialog box.
;(prompt "\nType SCB to create a section with a border.")
;(prompt "\nType SC to create a section without a border.")
;(prompt "\ntype SCD to delete entities inside rectangle.")
;(princ)

(defun cut_x ()
  (setq  C  0
        dcl_id (load_dialog "cut.dcl"))
  (if (not (new_dialog "cut" dcl_id))(exit))
    (action_tile "cut_outp" "(setq c 1)(done_dialog)")
    (action_tile "cut_out" "(setq c 2)(done_dialog)")
    (action_tile "cut_in" "(setq c 3)(done_dialog)")
    (action_tile "cancel" "(done_dialog)(exit)")

  (start_dialog)
  (unload_dialog dcl_id)
  (COND
       ((= C 1)(c:scb))
       ((= C 2)(c:sc))
       ((= C 3)(c:scd))
)
(princ)
)
(cut_x)
)
;;__________________________________________________________________
;;messages
(prompt "\nCut.LSP 调入 - 键入命令【Cut】执行.")
(princ)



lzy9788

创意还不错，不过有些慢，并且这样的修剪好像在工程图中用处不大。
另外，dcl文件可否上传？

xgwl

以前有过这样的程序,但由于只限于矩形框,所以不怎么用!

梦断江南

程序对spline，pline多次穿越矩形框的情况处理还不完善。另外应该设置undo标志，可以一步“u”回退。
xgwl ： snsy，aeo都贴过剪切的程序。不仅仅限制于矩形的。

seacatw

怎么出错了，CUT打完，然后SCB有小部分还是没有删除掉啊

TLHMQH

功能可以，但使用时出现下面提示，怎样修改？
命令: cut
; 错误: quit / exit abort

真龙天子

不能运行,cut命令后出现以下提示
错误 : quit / exit abort

kevinchan

对于椭圆和圆形或者任意多边形？？是否可以呢？

jaminth

非常需要这个程序!ths

betelzcm

精神还是可嘉的啦，鼓励一下！

lovein2002

精神还是可嘉的啦，鼓励一下！

zml84

遮挡即可，彻底删掉没有必要。

liyl123

ET工具箱里有,功能更强,速度也快
clipit