【方案讨论】用于CAD2006以下版本的框选剪切与延伸----方案1

wowan1314 · 发表于 2013-6-4 16:54:43

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 wowan1314 于 2013-6-12 21:29 编辑

支持块内线的----CAD2006以下用的框选剪切与延伸
最近利用GRREAD写了两个函数。YY:GETPOINT与YY:getcorner
LISPBOY要求写个示例代码！就拿下面这个程序当做示例代码吧！
其实这两函数都是为了此程序写的。完整代码详附件。
程序还有待完善。先贴出来看一看。大家有什么好建议也请讲一讲。

;;;===============================================================================;;;
;;;功能：可以点选和框选的修剪和延伸命令------BY wowan1314 ---支持块内线 ;;;
;;;===============================================================================;;;
(defun c:W ( / NJIAN NJIANC) (trim&extend1 T) )
(defun c:Z ( / NJIAN NJIANC) (trim&extend1 nil) )
(defun trim&extend1 (cmd / S1 S2 PT1 PT2 CMDECHO_OLD I XX YY:EXBLKH_SS YY:SSGET ENT EN YPT X Y PT liangx
error_end error zhuj2 zhuj1 PT3 PT4 OLDERR D2 SS1)
;;===============================增加循环框选，右键结束.
(DEFUN YY:SSGET (/ SS2 SS SS3 PT1 SSK)
;YY:SSGET主程序
(SETQ SS1 (SSADD) SS2 (SSADD) SS3 (SSADD) PT1 1 SSK (SSADD))
(while PT1
(SETQ PT1 (YY:GETPOINT '(T 12 2))) (IF PT1 (PROGN
(SETQ SS (YY:EXBLKH_SS PT1 SS3))
(AND (CAR SS) (SETQ SS1 (gxl-Sel-SSJoin SS1 (CAR SS))))
(AND (CADR SS) (SETQ SS2 (gxl-Sel-SSJoin SS2 (CADR SS))) (SETQ NJIAN SS2))
(AND (CADDR SS) (SETQ SS3 (gxl-Sel-SSJoin SS3 (CADDR SS))))
(AND (>(sslength ss1)0)(liangxian ss1 3))
))
)
(LIST SS1 SS2 SS3)
)
;;------------框选一次，如果有块，块炸到底，最后得到范围内除块和标注外的其他物体选择集
(DEFUN YY:EXBLKH_SS (P1 SS3 / P2 SS E0 SS0 SS1 S2 KC YANSE)
(if (setq S2 (ssget P1 '((0 . "~DIMENSION"))))
(PROGN
(IF (AND (ssget P1 '((0 . "INSERT"))) (SETQ SS (gxl-Sel-SSsub S2 SS3)))
(PROGN
(ss:map '(lambda (x)
(command "_.copy" X "" "0,0" "@")
(setq e0 (entlast) KC (DXF_READ 8 E0) YANSE (DXF_READ 62 (tblobjname "layer" KC)))
(YY:EXBLKALL E0);;块炸到底
(setq ss0 (last_ent e0));;块砸开后的物体集
(ss:map '(lambda (x) (AND (NOT(DXF_READ 62 X)) (YY_SubUpd X 62 YANSE)) ) SS0)
(SETQ SSK (gxl-Sel-SSJoin SS0 SSK) NJIAN SSK)
)
ss
)(SETQ P1 (osnap P1 "_near"))
(SETQ SS1 (ssget P1 '((-4 . "<AND")
(0 . "~DIMENSION")
(0 . "~INSERT")
(-4 . "AND>"))))
)
(SETQ SS1 S2)
))
(IF (CAR(SETQ P2 (YY:GETcorner P1 NIL 1314 NIL)))
(PROGN
(IF (SETQ SS (SSGET (if (minusp (CADR P2)) "_c" "_w") P1 (CAR P2) '((0 . "INSERT"))))
(PROGN
(SETQ SS (gxl-Sel-SSsub SS SS3))
(ss:map '(lambda (x)
(command "_.copy" X "" "0,0" "@")
(setq e0 (entlast) KC (DXF_READ 8 E0) YANSE (DXF_READ 62 (tblobjname "layer" KC)))
(YY:EXBLKALL E0);;块炸到底
(setq ss0 (last_ent e0));;块砸开后的物体集
(ss:map '(lambda (x) (AND (NOT(DXF_READ 62 X)) (YY_SubUpd X 62 YANSE)) ) SS0)
(SETQ SSK (gxl-Sel-SSJoin SS0 SSK) NJIAN SSK)
)
ss
))
)
(SETQ SS1 (SSGET (if (minusp (CADR P2)) "_c" "_w") P1 (CAR P2)
'((-4 . "<AND")
(0 . "~DIMENSION")
(0 . "~INSERT")
(-4 . "AND>"))))))
)
(LIST SS1 SSK SS)
)
;;-------------------------------出错函数
(defun error (x) (error_end))
(defun error_end ( / D2)
(setq *error* olderr)
(setvar "osmode" snap);打开捕捉
(IF S1 (liangxian s1 4 )) (IF SS1 (liangxian sS1 4 ))
(IF (AND NJIAN (>(SSLENGTH NJIAN)0))
(IF NJIANC (PROGN
(AND (tblobjname "layer" "NJIAN")(command ".Layer" "U" "NJIAN" ""))
(COMMAND "ERASE" NJIAN "") (SETQ D2 (VL-CATCH-ALL-APPLY 'VLA-deLETE (LIST NJIANC)))
(if(VL-CATCH-ALL-ERROR-P d2) (command "_.undo" "e"))
)
(COMMAND "ERASE" NJIAN "")
)
)
(command "_.undo" "e")
(if cm (setvar "cmdecho" cm))
)
;;;剪切主程序开始
(setq olderr *error* *error* error)
(setq CMDECHO_OLD (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(redraw)
(setq liangx 1)
(if cmd
(setq cmd "_.trim" zhuj1 "\n选择剪切边,或:<选择全部>:" zhuj2 "\n选择要修剪的对象，或 [栏选(F)/投影(P)/边(E)/放弃(U)]:" )
(setq cmd "_.extend" zhuj1 "\n选择边界的边,或:<选择全部>:" zhuj2 "\n选择要延伸的对象，或 [栏选(F)/投影(P)/边(E)/放弃(U)]:" )
)
(princ zhuj1)
;;若没有选取边界，就将全部对象作为边界
(setq snap (getvar "osmode"))
(IF (CADR (SSGETFIRST))(PROGN
(SETQ S1 (ssget ":S" '((-4 . "<AND")
(0 . "~DIMENSION")
(0 . "~INSERT")
(-4 . "AND>")))
) (command "_.undo" "be")(setvar "osmode" 0))
(PROGN
; (setvar "nomutt" 1)
(command "_.undo" "be")
(setvar "osmode" 0)
(if (AND (CAR(setq S1 (YY:ssget))) (>(SSLENGTH (CAR S1))0))
(SETQ NJIAN (CADR S1) S1 (CAR S1))
(progn
(setq S1 (ssget "all"))
(setq liangx NIL)
)
)
; (setvar "nomutt" 0)
(IF (AND NJIAN (>(SSLENGTH NJIAN)0)) (PROGN
(SETQ NJIANC (VLA-ADD (VLA-GET-LAYERS(vla-get-ActiveDocument (vlax-get-acad-object))) "NJIAN"))
(command ".chprop" NJIAN "" "layer" "NJIAN" "")
(command ".Layer" "Lo" "NJIAN" "" )))
);END PROGN
);END IF
(IF (NULL S1)
(PROGN (princ zhuj1)
; (setvar "nomutt" 1)
(command "_.undo" "be")
(setvar "osmode" 0)
(if (AND (CAR(setq S1 (YY:ssget))) (>(SSLENGTH (CAR S1))0))
(SETQ NJIAN (CADR S1) S1 (CAR S1))
(progn
(setq S1 (ssget "all"))
(setq liangx NIL)
)
)
; (setvar "nomutt" 0)
(IF (AND NJIAN (>(SSLENGTH NJIAN)0)) (PROGN
(SETQ NJIANC (VLA-ADD (VLA-GET-LAYERS(vla-get-ActiveDocument (vlax-get-acad-object))) "NJIAN"))
(command ".chprop" NJIAN "" "layer" "NJIAN" "")
(command ".Layer" "Lo" "NJIAN" "" )))
);END PROGN
)
(liangxian S1 3 )
(SETQ PT1 1)
(while PT1
(SETQ PT1 (YY:GETPOINT '(T 12 2)))
(princ zhuj2)
(cond
;;分支零下一：栏选
((= PT1 "F")
(PROGN
(SETQ PT1 (VECTORS))
(command cmd S1 "")
(apply 'command (append (LIST "F") PT1 (LIST "")))
(COMMAND "")))
;;分支一：投影选项设置
((= PT1 "P")
(progn
(initget 4)
(setq
XX (getint (strcat "\n输入投影选项 [无(0)/UCS(1)/视图(2)] <" (itoa (getvar "PROJMODE")) ">:" ) )
)
(if (or (= XX 0) (= XX 1) (= XX 2))
(setvar "PROJMODE" XX)
)
)
)
;;分支二：边延伸选项设置
((= PT1 "E")
(progn
(initget 4)
(setq XX (getint
(strcat
"\n输入隐含边延伸模式 [不延伸(0)/延伸(1)] <"
(itoa (getvar "EDGEMODE"))
">:"
)
)
)
(if (or (= XX 0) (= XX 1))
(setvar "EDGEMODE" XX)
)
)
)
;;分支四：撤销上一步操作
((= PT1 "U")
(command "_.undo" 1)
)
;;分支五：对选中的对象进行修剪操作
((listp PT1)
(progn
(if (setq S2 (ssget PT1 (getunlocklayer 0)))
(IF LIANGX
(progn
(command cmd S1 "" S2 "")
(liangxian s1 3 )
)
(progn
(command cmd "" S2 "")
(liangxian s1 3 )
)
)
(if (and (NULL (INITGET 32))
(setq PT2 (getcorner PT1 " >>>第二角点: "))
(setq S2 (ssget "c" PT1 PT2))
)
(IF LIANGX
(progn
(command cmd S1 "")
(progn
(setq pt3 (list (car pt1) (cadr pt2) 0.0)
pt4 (list (car pt2) (cadr pt1) 0.0)
)
(command "F" pt1 pt3 pt2 pt4 PT1 "")
)
(command "")
(liangxian s1 3 )
)
(progn
(command cmd "")
(progn
(setq pt3 (list (car pt1) (cadr pt2) 0.0)
pt4 (list (car pt2) (cadr pt1) 0.0)
)
(command "F" pt1 pt3 pt2 pt4 PT1 "")
)
(command "")
(liangxian s1 3 )
))
(princ "\n★未选择到对象。")
)
)
)
) ;_结束分支五
) ;_结束 cond 结束分支
) ;_结束 while
(error_end)
(princ)
) ;_结束 defun

;;;===============================================================================;;; 
;;;功能：可以点选和框选的修剪和延伸命令------BY wowan1314  ---支持块内线          ;;; 
;;;===============================================================================;;; 
(defun c:W ( / NJIAN NJIANC) (trim&extend1 T)  ) 
(defun c:Z ( / NJIAN NJIANC) (trim&extend1 nil) ) 
(defun trim&extend1 (cmd / S1 S2 PT1 PT2 CMDECHO_OLD I XX  YY:EXBLKH_SS YY:SSGET ENT EN YPT X Y PT liangx 
                           error_end error zhuj2 zhuj1 PT3 PT4 OLDERR D2 SS1)   
;;===============================增加循环框选，右键结束. 
(DEFUN YY:SSGET (/ SS2 SS SS3 PT1 SSK) 
;YY:SSGET主程序 
 (SETQ SS1 (SSADD) SS2 (SSADD) SS3 (SSADD) PT1 1 SSK (SSADD)) 
 (while PT1 
  (SETQ PT1 (YY:GETPOINT '(T 12 2))) (IF PT1 (PROGN 
  (SETQ SS (YY:EXBLKH_SS PT1 SS3)) 
  (AND (CAR SS) (SETQ SS1 (gxl-Sel-SSJoin SS1 (CAR SS)))) 
  (AND (CADR SS) (SETQ SS2 (gxl-Sel-SSJoin SS2 (CADR SS))) (SETQ NJIAN SS2)) 
  (AND (CADDR SS) (SETQ SS3 (gxl-Sel-SSJoin SS3 (CADDR SS)))) 
  (AND (>(sslength ss1)0)(liangxian ss1 3)) 
              )) 
 ) 
(LIST SS1 SS2 SS3) 
) 
 
;;------------框选一次，如果有块，块炸到底，最后得到范围内除块和标注外的其他物体选择集 
(DEFUN YY:EXBLKH_SS (P1 SS3 / P2 SS E0 SS0 SS1 S2 KC YANSE) 
 (if (setq S2 (ssget P1 '((0 . "~DIMENSION")))) 
  (PROGN 
    (IF (AND (ssget P1 '((0 . "INSERT"))) (SETQ SS (gxl-Sel-SSsub S2 SS3))) 
       (PROGN 
    (ss:map '(lambda (x)    
        (command "_.copy" X "" "0,0" "@") 
       (setq e0 (entlast) KC (DXF_READ 8 E0) YANSE (DXF_READ 62 (tblobjname "layer" KC))) 
      (YY:EXBLKALL E0);;块炸到底 
       (setq ss0 (last_ent e0));;块砸开后的物体集 
       (ss:map '(lambda (x) (AND (NOT(DXF_READ 62 X)) (YY_SubUpd X 62 YANSE)) ) SS0) 
        (SETQ SSK (gxl-Sel-SSJoin SS0 SSK) NJIAN SSK) 
      ) 
     ss 
    )(SETQ P1 (osnap P1 "_near")) 
     (SETQ SS1 (ssget P1 '((-4 . "<AND") 
    (0 . "~DIMENSION") 
    (0 . "~INSERT") 
    (-4 . "AND>")))) 
   ) 
  (SETQ SS1 S2) 
  )) 
  (IF (CAR(SETQ P2 (YY:GETcorner P1 NIL 1314 NIL))) 
   (PROGN 
   (IF (SETQ SS (SSGET (if (minusp (CADR P2)) "_c" "_w") P1 (CAR P2) '((0 . "INSERT")))) 
    (PROGN 
    (SETQ SS (gxl-Sel-SSsub SS SS3)) 
    (ss:map '(lambda (x)    
        (command "_.copy" X "" "0,0" "@") 
       (setq e0 (entlast) KC (DXF_READ 8 E0) YANSE (DXF_READ 62 (tblobjname "layer" KC))) 
      (YY:EXBLKALL E0);;块炸到底 
       (setq ss0 (last_ent e0));;块砸开后的物体集 
       (ss:map '(lambda (x) (AND (NOT(DXF_READ 62 X)) (YY_SubUpd X 62 YANSE)) ) SS0) 
        (SETQ SSK (gxl-Sel-SSJoin SS0 SSK) NJIAN SSK) 
      ) 
     ss 
    )) 
   ) 
   (SETQ SS1 (SSGET (if (minusp (CADR P2)) "_c" "_w") P1 (CAR P2) 
    '((-4 . "<AND") 
    (0 . "~DIMENSION") 
    (0 . "~INSERT") 
    (-4 . "AND>")))))) 
 ) 
(LIST SS1 SSK SS) 
) 
;;-------------------------------出错函数 
   (defun error (x) (error_end)) 
   (defun error_end ( / D2) 
      (setq *error* olderr) 
      (setvar "osmode" snap);打开捕捉 
     (IF S1 (liangxian s1 4 )) (IF SS1 (liangxian sS1 4 )) 
     (IF (AND NJIAN (>(SSLENGTH NJIAN)0)) 
           (IF NJIANC (PROGN 
              (AND (tblobjname "layer" "NJIAN")(command ".Layer" "U" "NJIAN" "")) 
              (COMMAND "ERASE" NJIAN "") (SETQ D2 (VL-CATCH-ALL-APPLY 'VLA-deLETE (LIST NJIANC))) 
              (if(VL-CATCH-ALL-ERROR-P d2) (command "_.undo" "e")) 
                      ) 
              (COMMAND "ERASE" NJIAN "") 
           ) 
     ) 
     (command "_.undo" "e") 
      (if cm (setvar "cmdecho" cm)) 
   ) 
;;;剪切主程序开始 
   (setq olderr *error* *error* error) 
   (setq CMDECHO_OLD (getvar "CMDECHO")) 
   (setvar "CMDECHO" 0) 
   (redraw) 
   (setq liangx 1) 
 
   (if cmd 
      (setq cmd "_.trim"  zhuj1  "\n选择剪切边,或:<选择全部>:"  zhuj2    "\n选择要修剪的对象，或 [栏选(F)/投影(P)/边(E)/放弃(U)]:" ) 
      (setq cmd "_.extend"  zhuj1  "\n选择边界的边,或:<选择全部>:"  zhuj2   "\n选择要延伸的对象，或 [栏选(F)/投影(P)/边(E)/放弃(U)]:" ) 
   ) 
 
   (princ zhuj1) 
   ;;若没有选取边界，就将全部对象作为边界 
   (setq snap (getvar "osmode")) 
 
(IF (CADR (SSGETFIRST))(PROGN 
  (SETQ S1 (ssget ":S" '((-4 . "<AND") 
    (0 . "~DIMENSION") 
    (0 . "~INSERT") 
    (-4 . "AND>"))) 
  ) (command "_.undo" "be")(setvar "osmode" 0)) 
(PROGN 
;   (setvar "nomutt" 1) 
  (command "_.undo" "be") 
(setvar "osmode" 0) 
   (if (AND (CAR(setq S1 (YY:ssget))) (>(SSLENGTH (CAR S1))0)) 
      (SETQ NJIAN (CADR S1) S1 (CAR S1)) 
      (progn 
         (setq S1 (ssget "all")) 
         (setq liangx NIL) 
      ) 
   ) 
;   (setvar "nomutt" 0) 
(IF (AND NJIAN (>(SSLENGTH NJIAN)0)) (PROGN 
(SETQ NJIANC (VLA-ADD (VLA-GET-LAYERS(vla-get-ActiveDocument (vlax-get-acad-object))) "NJIAN")) 
(command ".chprop" NJIAN "" "layer" "NJIAN" "") 
(command ".Layer" "Lo" "NJIAN" "" ))) 
);END PROGN 
);END IF 
 
(IF (NULL S1) 
(PROGN (princ zhuj1) 
;   (setvar "nomutt" 1) 
  (command "_.undo" "be") 
(setvar "osmode" 0) 
   (if (AND (CAR(setq S1 (YY:ssget))) (>(SSLENGTH (CAR S1))0)) 
      (SETQ NJIAN (CADR S1) S1 (CAR S1)) 
      (progn 
         (setq S1 (ssget "all")) 
         (setq liangx NIL) 
      ) 
   ) 
;   (setvar "nomutt" 0) 
(IF (AND NJIAN (>(SSLENGTH NJIAN)0)) (PROGN 
(SETQ NJIANC (VLA-ADD (VLA-GET-LAYERS(vla-get-ActiveDocument (vlax-get-acad-object))) "NJIAN")) 
(command ".chprop" NJIAN "" "layer" "NJIAN" "") 
(command ".Layer" "Lo" "NJIAN" "" ))) 
);END PROGN 
) 
 
 (liangxian S1 3 ) 
(SETQ PT1 1) 
   (while PT1 
      (SETQ PT1 (YY:GETPOINT '(T 12 2))) 
      (princ zhuj2) 
  (cond 
      ;;分支零下一：栏选 
        ((= PT1 "F") 
         (PROGN 
           (SETQ PT1 (VECTORS)) 
           (command cmd S1 "") 
           (apply 'command (append (LIST "F") PT1 (LIST ""))) 
           (COMMAND ""))) 
      ;;分支一：投影选项设置 
        ((= PT1 "P") 
       (progn 
       (initget 4) 
       (setq 
           XX (getint (strcat "\n输入投影选项 [无(0)/UCS(1)/视图(2)] <" (itoa (getvar "PROJMODE"))  ">:"  ) ) 
       ) 
       (if (or (= XX 0) (= XX 1) (= XX 2)) 
             (setvar "PROJMODE" XX) 
       ) 
       ) 
      ) 
      ;;分支二：边延伸选项设置 
        ((= PT1 "E") 
       (progn 
       (initget 4) 
       (setq XX (getint 
                (strcat 
                  "\n输入隐含边延伸模式 [不延伸(0)/延伸(1)] <" 
                  (itoa (getvar "EDGEMODE")) 
                  ">:" 
                ) 
            ) 
       ) 
       (if (or (= XX 0) (= XX 1)) 
             (setvar "EDGEMODE" XX) 
       ) 
       ) 
      ) 
      ;;分支四：撤销上一步操作 
        ((= PT1 "U") 
         (command "_.undo" 1) 
      ) 
      ;;分支五：对选中的对象进行修剪操作 
      ((listp PT1) 
      (progn 
      (if (setq S2 (ssget PT1 (getunlocklayer 0))) 
        (IF LIANGX 
          (progn 
             (command cmd S1 "" S2 "") 
             (liangxian s1 3 ) 
          ) 
          (progn 
             (command cmd "" S2 "") 
             (liangxian s1 3 ) 
          ) 
        ) 
          (if (and (NULL (INITGET 32)) 
                   (setq PT2 (getcorner PT1 " >>>第二角点: ")) 
                   (setq S2 (ssget "c" PT1 PT2)) 
              ) 
           (IF LIANGX 
             (progn            
                (command cmd S1 "") 
                  (progn 
                  (setq pt3 (list (car pt1) (cadr pt2) 0.0) 
                        pt4 (list (car pt2) (cadr pt1) 0.0) 
                  ) 
                  (command "F" pt1 pt3 pt2 pt4 PT1 "") 
                  ) 
                  (command "") 
                (liangxian s1 3 ) 
                  
             ) 
             (progn            
                (command cmd "") 
                  (progn 
                  (setq pt3 (list (car pt1) (cadr pt2) 0.0) 
                        pt4 (list (car pt2) (cadr pt1) 0.0) 
                  ) 
                  (command "F" pt1 pt3 pt2 pt4 PT1 "") 
                  ) 
                  (command "") 
                (liangxian s1 3 ) 
                  
             )) 
             (princ "\n★未选择到对象。") 
         ) 
     ) 
     ) 
      ) ;_结束 分支五 
  ) ;_结束 cond 结束分支 
   ) ;_结束 while 
   (error_end) 
   (princ) 
) ;_结束 defun

Lispboy · 发表于 2013-6-4 17:52:04

代表全体LISPER第一时间发来贺电。

Lispboy · 发表于 2013-6-4 17:56:29

Lispboy 发表于 2013-6-4 17:52
代表全体LISPER第一时间发来贺电。

好像还缺个动画演示;P 不要打我。

wowan1314 · 发表于 2013-6-4 18:01:29

Lispboy 发表于 2013-6-4 17:56
好像还缺个动画演示不要打我。

不贴动画了！这个功能大家都清楚！！

QiaoCheng · 发表于 2013-6-4 18:02:13

高版本CAD电脑配不起，这个适合
能不能增加对外对内的？

wowan1314 · 发表于 2013-6-4 18:28:55

QiaoCheng 发表于 2013-6-4 18:02
高版本CAD电脑配不起，这个适合
能不能增加对外对内的？

这个程序很多地方还有待完善，这样是不适合直接使用的！

你就又给我新的课题了呀！

Lispboy · 发表于 2013-6-4 18:51:12

wowan1314 发表于 2013-6-4 18:28
这个程序很多地方还有待完善，这样是不适合直接使用的！

你就又给我新的课题了呀！

这样每天才有追求，哈哈。;P

QiaoCheng · 发表于 2013-6-4 21:04:23

wowan1314 发表于 2013-6-4 18:28
这个程序很多地方还有待完善，这样是不适合直接使用的！

你就又给我新的课题了呀！

不敢不敢，只是我编不出来，这个有时会用到

QiaoCheng · 发表于 2013-6-4 22:37:18

无意中在存库里翻到这个,不知道是那来的，觉得代码里考虑的比较周到
借楼主的贴放在这{:soso_e113:}
[pcode=lisp,true]
(defun c:cc ( / *error* *acad* doc ps osm as om emode pmode offd
 elev locked typ typlst e d notclosed splinetyp
 i o intpts lst sc minpt maxpt hidelst dellst
 offsetename offsetobj trimename trimobj curcoord
 mark postlst coord reg selfinter ext UCSpkpt
 UCStrimobjpts WCStrimobjpts delother side
 ssinside ssall sscross ssoutside ssintersect
 solidflag solidans solidlst sskeep sstest testename
 WCSoffsetobjpts UCSoffsetobjpts
 GetScreenCoords TraceObject GetInters
 SpinBar AfterEnt CommandExplode
 ExpNestedBlock FirstLastPts GetBlock
 AttributesToText UniformScale
 SSVLAList Inside UnlockLayers
 RelockLayers ZoomToPointList Extents)
 (defun *error* (msg)
(cond
 ((not msg))
 ((wcmatch (strcase msg) "*QUIT*,*CANCEL*"))
 (T (princ (strcat "\n错误: " msg)))
)
(setvar "pickstyle" ps) ;控制编组选择和关联填充选择的使用
(setvar "osmode" osm) ;对象捕捉
(setvar "autosnap" as) ;自动捕捉
(setvar "edgemode" emode) ;控制 TRIM 和 EXTEND 命令确定边界的边和剪切边的方式
(setvar "projmode" pmode) ;设置修剪和延伸的当前“投影”模式
(setvar "orthomode" om) ;限制光标在正交方向移动
(setvar "elevation" elev) ;存储当前空间当前视口中相对当前 UCS 的当前标高值
(setvar "offsetdist" offd) ;设置默认的偏移距离
(setvar "cmdecho" 1) ;回显提示
(if (and offsetobj (not (vlax-erased-p offsetobj))) ;如果offsetobj没有被删除则删除
 (vla-Delete offsetobj)
)
(if testename (entdel testename)) ;如果图元存在则删除
(foreach x hidelst
 (if (not (vlax-erased-p x))
 (vlax-put x 'Visible acTrue)
 )
)
(if (and trimobj (not (vlax-erased-p trimobj)))
 (vla-Highlight trimobj acFalse)
)
(RelockLayers locked)
(vla-EndUndoMark doc)
(princ)
 )
 ;;;点集的最大点(右上角)及最小点(左下角)
 (defun Extents (Plist)
 (list
 (apply 'mapcar (cons 'min plist))
 (apply 'mapcar (cons 'max plist))
 )
 )
 ;;;窗口显示
 (defun ZoomToPointList (pts)
(setq pts (Extents pts))
(vlax-invoke *acad* 'ZoomWindow (car pts) (cadr pts))
(vlax-invoke *acad* 'ZoomScaled 0.85 acZoomScaledRelative)
 )
 ;;;解锁图层
 (defun UnlockLayers (doc / laylst)
(vlax-for x (vla-get-Layers doc)
 (if
 (and
 (not (vl-string-search "|" (vlax-get x 'Name)))
 (eq :vlax-true (vla-get-Lock x))
 )
 (progn
 (setq laylst (cons x laylst))
 (vla-put-Lock x :vlax-false)
 )
 )
)
laylst
 )
 (defun RelockLayers (lst)
(foreach x lst
 (vl-catch-all-apply 'vla-put-lock (list x :vlax-true))
)
 )
 ;;;当前视口的高度
 (defun GetScreenCoords ( / ViwCen ViwDim ViwSiz VptMin VptMax)
(setq ViwSiz (/ (getvar "VIEWSIZE") 2.0)
 ViwCen (getvar "VIEWCTR")
 ViwDim (list (* ViwSiz (apply '/ (getvar "SCREENSIZE"))) ViwSiz)
 VptMin (mapcar '- ViwCen ViwDim)
 VptMax (mapcar '+ ViwCen ViwDim)
)
(list VptMin VptMax)
 )
 ;;;图形范围右上角点的值和左下角点的值
 (defun Inside (p ptlist / p2 i n k)
 (setq p2 (polar p 0.0 (distance (getvar "extmin") (getvar "extmax"))))
 ;;如果点集中起点与终点不一样，则在点集尾部添加起点
 (if (not (equal (car ptlist) (last ptlist) 1e-10))
 (setq ptlist (append ptlist (list (car ptlist))))
 )
 (setq i 0 k 0 n (1- (length ptlist))) ;初始化值
 (while (< i n)
 (if (inters p p2 (nth i ptlist) (nth (1+ i) ptlist)) ;计算交点
 (setq k (1+ k))
 )
 (setq i (1+ i))
 )
 (not (zerop (rem k 2)))
 )
 ;;;选择集转Vla表
 (defun SSVLAList (ss / obj lst i)
(setq i 0)
(if ss
 (repeat (sslength ss)
 (setq obj (vlax-ename->vla-object (ssname ss i))
 lst (cons obj lst)
 i (1+ i)
 )
 )
)
(reverse lst)
 )
 ;;;
 (defun AfterEnt (ent / lst entlst)
(while (setq ent (entnext ent))
 (setq entlst (entget ent))
 (if
 (and
 (not (wcmatch (cdr (assoc 0 entlst)) "ATTRIB,VERTEX,SEQEND"))
 (eq (cdr (assoc 410 entlst)) (getvar "ctab")) ;当前（模型或布局）选项卡的名称
 )
 (setq lst (cons ent lst))
 )
)
(reverse lst)
 )
 ;;;进度条
 (defun SpinBar (sbar)
(cond ((= sbar "\\") "|")
 ((= sbar "|") "/")
 ((= sbar "/") "-")
 (t "\\")
)
 )
 ;;;跟踪对象
 (defun TraceObject (obj / typlst typ ZZeroList TracePline TraceCE TraceSpline)
(defun ZZeroList (lst)
 (mapcar '(lambda (p) (list (car p) (cadr p) 0.0)) lst)
)
(defun TracePline (obj / param endparam anginc tparam pt blg ptlst delta inc arcparam flag)
 (setq param (vlax-curve-getStartParam obj) ;曲线的开始参数
 endparam (vlax-curve-getEndParam obj)
 anginc (* pi (/ 2.5 180.0))
 )
 (while (<= param endparam)
 (setq pt (vlax-curve-getPointAtParam obj param))
 ;去除重复点
 (if (not (equal pt (car ptlst) 1e-12))
 (setq ptlst (cons pt ptlst))
 )
 (if
 (and
 (/= param endparam)
 (setq blg (abs (vlax-invoke obj 'GetBulge param)))
 (/= 0 blg)
 )
 (progn
 (setq delta (* 4 (atan blg))
 inc (/ 1.0 (1+ (fix (/ delta anginc))))
 arcparam (+ param inc)
 )
 (while (< arcparam (1+ param))
 (setq pt (vlax-curve-getPointAtParam obj arcparam)
 ptlst (cons pt ptlst)
 arcparam (+ inc arcparam)
 )
 )
 )
 )
 (setq param (1+ param))
 )
 (if (> (length ptlst) 1)
 (progn
 (setq ptlst (vl-remove nil ptlst))
 (ZZeroList (reverse ptlst))
 )
 )
)
(defun TraceCE (obj / startparam endparam anginc delta div inc pt ptlst)
 (setq startparam (vlax-curve-getStartParam obj)
 endparam (vlax-curve-getEndParam obj)
 anginc (* pi (/ 2.5 180.0))
 )
 (if (equal endparam (* pi 2) 1e-6)
 (setq delta endparam)
 (setq delta (abs (- endparam startparam)))
 )
 (setq div (1+ (fix (/ delta anginc)))
 inc (/ delta div)
 )
 (while
 (or
 (< startparam endparam)
 (equal startparam endparam 1e-12)
 )
 (setq pt (vlax-curve-getPointAtParam obj startparam)
 ptlst (cons pt ptlst)
 startparam (+ inc startparam)
 )
 )
 (ZZeroList (reverse ptlst))
)
(defun TraceSpline (obj / startparam endparam ncpts inc param fd ptlst pt1 pt2 ang1 ang2 a)
 (setq startparam (vlax-curve-getStartParam obj)
 endparam (vlax-curve-getEndParam obj)
 ncpts (vlax-get obj 'NumberOfControlPoints)
 inc (/ (- endparam startparam) (* ncpts 6))
 param (+ inc startparam)
 fd (vlax-curve-getFirstDeriv obj param)
 ptlst (cons (vlax-curve-getStartPoint obj) ptlst)
 )
 (while (< param endparam)
 (setq pt1 (vlax-curve-getPointAtParam obj param)
 ang1 (angle pt1 (mapcar '+ pt1 fd))
 param (+ param inc)
 pt2 (vlax-curve-getPointAtParam obj param)
 fd (vlax-curve-getfirstderiv obj param)
 ang2 (angle pt2 (mapcar '+ pt2 fd))
 a (abs (@delta ang1 ang2))
 )
 (if (> a 0.00436332)
 (setq ptlst (cons pt1 ptlst))
 )
 )
 (if (not (equal (setq pt1 (vlax-curve-getEndPoint obj)) (car ptlst) 1e-8))
 (setq ptlst (cons pt1 ptlst))
 )
 (ZZeroList (reverse ptlst))
)
(setq typlst '("AcDb2dPolyline" "AcDbPolyline" "AcDbSpline" "AcDbCircle" "AcDbEllipse"))
(or
 (eq (type obj) 'VLA-OBJECT)
 (setq obj (vlax-ename->vla-object obj))
)
(setq typ (vlax-get obj 'ObjectName))
(if (vl-position typ typlst)
 (cond
 ((or (eq typ "AcDb2dPolyline") (eq typ "AcDbPolyline"))
 (cond
 ((or
 (not (vlax-property-available-p obj 'Type))
 (= 0 (vlax-get obj 'Type))
 )
 (TracePline obj)
 )
 )
 )
 ((or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
 (TraceCE obj)
 )
 ((eq typ "AcDbSpline")
 (TraceSpline obj)
 )
 )
)
 )
 ;;;交点函数
 (defun GetInters (firstobj nextobj mode / coord ptlst)
(if (= (type firstobj) 'ENAME)
 (setq firstobj (vlax-ename->vla-object firstobj)))
(if (= (type nextobj) 'ENAME)
 (setq nextobj (vlax-ename->vla-object nextobj)))
(if
 (not
 (vl-catch-all-error-p
 (setq coord (vl-catch-all-apply 'vlax-invoke
 (list firstobj 'IntersectWith nextobj mode)))
 )
 )
 (repeat (/ (length coord) 3)
 (setq ptlst (cons (list (car coord) (cadr coord) (caddr coord)) ptlst))
 (setq coord (cdddr coord))
 )
)
(reverse ptlst)
 )
 ;;;块处理
 (defun CommandExplode (obj / lay mark attlst Name exlst newattlst)
(setq mark (entlast))
(if
 (and
 (not (vlax-erased-p obj))
 (eq "AcDbBlockReference" (vlax-get obj 'ObjectName))
 )
 (progn
 (setq lay (vlax-get obj 'Layer)
 attlst (vlax-invoke obj 'GetAttributes)
 )
 (vl-cmdf "._explode" (vlax-vla-object->ename obj))
 (command)
 (if
 (and
 (not (eq mark (entlast)))
 (setq exlst (SSVLAList (ssget "_p")))
 )
 (progn
 (setq newattlst (AttributesToText attlst))
 (foreach x exlst
 (if (eq "AcDbAttributeDefinition" (vlax-get x 'ObjectName))
 (vla-delete x)
 )
 )
 (setq exlst (vl-remove-if 'vlax-erased-p exlst))
 (if newattlst (setq exlst (append exlst newattlst)))
 (foreach x exlst
 (if (eq "0" (vlax-get x 'Layer))
 (vlax-put x 'Layer lay)
 )
 (if (zerop (vlax-get x 'Color))
 (vlax-put x 'Color 256)
 )
 )
 )
 )
 )
)
(foreach x exlst
 (if
 (and
 (not (vlax-erased-p x))
 (eq "AcDbBlockReference" (vlax-get x 'ObjectName))
 )
 (ExpNestedBlock x)
 )
)
 )
 ;;;重生成块
 (defun ExpNestedBlock (obj / lay lst attlst)
(princ
 (strcat "\r正在处理块,等稍等... "
 (setq *sbar (SpinBar *sbar)) "\t") ;进度条
)
(if
 (and obj (not (vlax-erased-p obj)))
 (cond
 ((not (UniformScale obj))
 (CommandExplode obj)
 )
 (T
 (setq lay (vlax-get obj 'Layer))
 (if (eq "AcDbBlockReference" (vlax-get obj 'ObjectName))
 (setq attlst (AttributesToText (vlax-invoke obj 'GetAttributes)))
 )
 (setq lst (vl-catch-all-apply 'vlax-invoke (list obj 'Explode)))
 (if attlst (setq lst (append lst attlst)))
 (if (listp lst)
 (foreach x lst
 (vla-Update x)
 (if (eq "AcDbBlockReference" (vlax-get x 'ObjectName))
 (ExpNestedBlock x)
 (progn
 (if
 (and
 (not (vlax-erased-p x))
 (eq "0" (vlax-get x 'Layer))
 )
 (vlax-put x 'Layer lay)
 )
 (if
 (and
 (not (vlax-erased-p x))
 (zerop (vlax-get x 'Color))
 )
 (vlax-put x 'Color 256)
 )
 (if
 (and
 (not (vlax-erased-p x))
 (eq "AcDbAttributeDefinition" (vlax-get x 'ObjectName))
 )
 (vla-Delete x)
 )
 )
 )
 )
 )
 (vla-Delete obj)
 )
 )
)
 )
 (defun FirstLastPts (obj / p1 p2)
(setq p1 (vlax-curve-getPointAtParam obj (vlax-curve-getStartParam obj)))
(setq p2 (vlax-curve-getPointAtParam obj (vlax-curve-getEndParam obj)))
(equal p1 p2 1e-10)
 )
 ;;;获取块函数
 (defun GetBlock ()
(vlax-get (vla-get-ActiveLayout doc) 'Block)
 )
 (defun AttributesToText (attlst / elst res)
(foreach x attlst
 (setq elst (entget (vlax-vla-object->ename x)))
 (if
 (entmake
 (list
 '(0 . "TEXT")
 (cons 1 (vlax-get x 'TextString))
 (cons 7 (vlax-get x 'StyleName))
 (cons 8 (vlax-get x 'Layer))
 (cons 10 (vlax-get x 'InsertionPoint))
 (cons 11 (vlax-get x 'TextAlignmentPoint))
 (cons 40 (vlax-get x 'Height))
 (cons 41 (vlax-get x 'ScaleFactor))
 (cons 50 (vlax-get x 'Rotation))
 (cons 51 (vlax-get x 'ObliqueAngle))
 (cons 62 (vlax-get x 'Color))
 (cons 67 (cdr (assoc 67 elst)))
 (cons 71 (cdr (assoc 71 elst)))
 (cons 72 (cdr (assoc 72 elst)))
 (cons 73 (cdr (assoc 73 elst)))
 (cons 410 (cdr (assoc 410 elst)))
 )
 )
 (setq res (cons (vlax-ename->vla-object (entlast)) res))
 )
)
res
 )
 (defun UniformScale (obj / x y z)
(and
 (or
 (= (type obj) 'VLA-object)
 (if (= (type obj) 'ENAME)
 (setq obj (vlax-ename->vla-object obj))
 )
 )
 (or
 (wcmatch (vlax-get obj 'ObjectName) "*Dimension")
 (and
 (= "AcDbBlockReference" (vlax-get obj 'ObjectName))
 (setq x (vlax-get obj 'XScaleFactor))
 (setq y (vlax-get obj 'YScaleFactor))
 (setq z (vlax-get obj 'ZScaleFactor))
 (and
 (equal (abs x) (abs y) 1e-8)
 (equal (abs y) (abs z) 1e-8)
 )
 )
 )
)
 )
 (defun SortInterPoints (obj pts / lst)
(if
 (vl-catch-all-error-p
 (vl-catch-all-apply 'vlax-curve-getEndParam (list obj))
 )
 pts
 (progn
 (setq lst (mapcar '(lambda (y) (vlax-curve-getParamAtPoint obj y)) pts)
 lst (mapcar '(lambda (y z) (list y z)) lst pts)
 lst (vl-sort lst '(lambda (a b) (< (car a) (car b))))
 )
 (mapcar 'cadr lst)
 )
)
 )
 (vl-load-com)
 (setq *acad* (vlax-get-acad-object)
 doc (vla-get-ActiveDocument *acad*)
 )
 (vla-StartUndoMark doc)
 (setq locked (UnlockLayers doc))
 (setq ps (getvar "pickstyle"))
 (setvar "pickstyle" 0)
 (setvar "cmdecho" 0)
 (setq elev (getvar "elevation"))
 (setvar "elevation" 0.0)
 (setq osm (getvar "osmode"))
 (setvar "osmode" 0)
 (setq as (getvar "autosnap"))
 (setvar "autosnap" 0)
 (setq om (getvar "orthomode"))
 (setvar "orthomode" 0)
 (setq emode (getvar "edgemode"))
 (setvar "edgemode" 0)
 (setq pmode (getvar "projmode"))
 (setvar "projmode" 0)
 (setq offd (getvar "offsetdist"))
 (sssetfirst)
 (setq typlst '("AcDbCircle" "AcDbPolyline" "AcDb2dPolyline" "AcDbEllipse" "AcDbSpline"))
 (setvar "errno" 0)
 (while
(or
 (not (setq e (car (entsel "\n选择圆、封闭线，椭圆或样条曲线进行修剪: "))))
 (not (setq trimobj (vlax-ename->vla-object e)))
 (not (vl-position (setq typ (vlax-get trimobj 'ObjectName)) typlst))
 (and (not (FirstLastPts trimobj)) (setq notclosed T))
 (and
 (wcmatch typ "*Polyline")
 (vlax-property-available-p trimobj 'Type)
 (not (zerop (vlax-get trimobj 'Type)))
 (setq splinetyp T)
 )
 (and
 (wcmatch typ "*Polyline,AcDbSpline")
 (vl-catch-all-error-p
 (setq reg
 (vl-catch-all-apply 'vlax-invoke
 (list (GetBlock) 'AddRegion (list trimobj))
 )
 )
 )
 (setq selfinter T)
 )
)
(cond
 ((= 52 (getvar "errno"))
 (exit)
 )
 ((not e)
 (princ "\n Missed pick. ")
 )
 (selfinter
 (princ "\n Selected object intersects itself, try again. ")
 (setq selfinter nil)
 )
 (notclosed
 (princ "\n Selected object is not closed, try again. ")
 (setq notclosed nil)
 )
 (splinetyp
 (princ "\n Polyline spline selected, try again. ")
 (setq splinetyp nil)
 )
 (typ
 (princ (strcat "\n " (substr typ 5) " selected, try again. "))
 (setq typ nil)
 )
)
 )
 (if (and reg (not (vl-catch-all-error-p reg)))
(vla-Delete (car reg))
 )
 (setq trimename (vlax-vla-object->ename trimobj))
 (setq curcoord (GetScreenCoords))
 (vla-Highlight trimobj acTrue)
 (initget 1)
 (setq UCSpkpt (getpoint "\n用一点指定剪切方向: "))
 (setq WCStrimobjpts (TraceObject trimobj))
 (setq UCStrimobjpts
(mapcar '(lambda (x) (trans x 0 1)) WCStrimobjpts)
 )
 (if (Inside UCSpkpt UCStrimobjpts)
(setq side "inside")
(setq side "outside")
 )
 (setq ext (Extents WCStrimobjpts))
 (setq d (distance (car ext) (cadr ext)))
 (setq d (/ d 1500.0))
 (if (= 2 (getvar "lunits"))
(setq d (/ d 12.0))
 )
 (setq mark (entlast))
 (vl-cmdf "._offset" d (vlax-vla-object->ename trimobj) UCSpkpt "_exit")
 (setq offsetename (entlast))
 (if (/= 1 (length (setq dellst (AfterEnt mark))))
(progn
 (princ "\nProblem detected with selected object. Try another. Exiting... ")
 (foreach x dellst (entdel x))
 (exit)
)
 )
 (setq offsetobj (vlax-ename->vla-object offsetename))
 (vlax-put offsetobj 'Visible 0)
 (setq hidelst (cons offsetobj hidelst))
 (initget "Yes No")
 (setq delother (getkword (strcat "\n是否进行剪切" side "? [Yes/No] <N>: ")))
 (if (not delother) (setq delother "No"))
 (vlax-invoke *acad* 'ZoomExtents)
 (setq sc (GetScreenCoords))
 (setq minpt (car sc))
 (setq maxpt (cadr sc))
 (vlax-put trimobj 'Visible 0)
 (setq hidelst (cons trimobj hidelst))
 (setq sscross (ssget "cp" UCStrimobjpts '((0 . "INSERT"))))
 (if (not (setq ssinside (ssget "wp" UCStrimobjpts '((0 . "INSERT")))))
(setq ssinside (ssadd))
 )
 (setq i 0)
 (if sscross
(repeat (sslength sscross)
 (setq e (ssname sscross i))
 (if
 (and
 (not (ssmemb e ssinside))
 (setq o (vlax-ename->vla-object e))
 (not (vlax-erased-p o))
 (vlax-property-available-p o 'Path)
 )
 (progn
 (CommandExplode o)
 (if (not (vlax-erased-p o))
 (progn
 (vlax-put o 'Visible 0)
 (setq hidelst (cons o hidelst))
 )
 )
 )
 (ExpNestedBlock o)
 )
 (setq i (1+ i))
)
 )
 (setq i 0 sscross nil ssinside nil)
 (setq sscross (ssget "cp" UCStrimobjpts '((0 . "HATCH"))))
 (if (not (setq ssinside (ssget "wp" UCStrimobjpts '((0 . "HATCH")))))
(setq ssinside (ssadd))
 )
 (if sscross
(repeat (sslength sscross)
 (setq e (ssname sscross i))
 (if
 (and
 (not (ssmemb e ssinside))
 (setq o (vlax-ename->vla-object e))
 (eq "AcDbHatch" (vlax-get o 'ObjectName))
 (eq "SOLID" (vlax-get o 'PatternName))
 )
 (setq solidflag T
 solidlst (cons e solidlst)
 )
 )
 (setq i (1+ i))
)
 )
 (if solidflag
(progn
 (initget "Yes No")
 (setq solidans (getkword "\nConvert solid hatch to lines? [Yes/No] <N>: "))
 (if (eq "Yes" solidans)
 (foreach x solidlst
 (command "._-hatchedit" x "_properties" "ANSI31" (* d 8) 0.0)
 (vlax-put (vlax-ename->vla-object x) 'AssociativeHatch 0)
 (command "._explode" x)
 )
 )
)
 )
 (setq i 0 sscross nil ssinside nil)
 (setq sscross (ssget "cp" UCStrimobjpts '((0 . "HATCH,REGION"))))
 (if (not (setq ssinside (ssget "wp" UCStrimobjpts '((0 . "HATCH,REGION")))))
(setq ssinside (ssadd))
 )
 (if sscross
(repeat (sslength sscross)
 (setq e (ssname sscross i))
 (if
 (and
 (not (ssmemb e ssinside))
 (not (vl-position e solidlst))
 )
 (progn
 (setq o (vlax-ename->vla-object e))
 (if (vlax-property-available-p o 'AssociativeHatch)
 (vlax-put o 'AssociativeHatch 0)
 )
 (command "._explode" e)
 )
 )
 (setq i (1+ i))
)
 )
 (setq sscross nil ssinside nil)
 (setq ssall (ssget "c" minpt maxpt))
 (if (not (setq ssinside (ssget "wp" UCStrimobjpts)))
(setq ssinside (ssadd))
 )
 (if (not (setq sscross (ssget "cp" UCStrimobjpts))) ;var added
(setq sscross (ssadd))
 )
 (setq i 0)
 (setq ssoutside (ssadd))
 (repeat (sslength ssall)
(setq e (ssname ssall i))
(if (not (ssmemb e sscross))
 (ssadd e ssoutside)
)
(setq i (1+ i))
 )
 (setq i 0)
 (setq ssintersect (ssadd))
 (repeat (sslength sscross)
(setq e (ssname sscross i))
(if
 (and
 (not (ssmemb e ssinside))
 (not (vl-position e solidlst))
 (GetInters e trimobj acExtendNone)
 )
 (ssadd e ssintersect)
 (ssadd e ssinside)
)
(setq i (1+ i))
 )
 (if (eq "Yes" delother)
(cond
 ((eq side "inside")
 (ssdel trimename ssinside)
 (command "._erase" ssinside "")
 )
 ((eq side "outside")
 (ssdel trimename ssoutside)
 (command "._erase" ssoutside "")
 )
)
 )
 (setq lst (SSVLAList ssintersect))
 (setq lst
(vl-remove-if
 '(lambda (x)
 (setq typ (vlax-get x 'ObjectName))
 (or
 (eq "AcDbText" typ)
 (eq "AcDbMText" typ)
 (eq "AcDbLeader" typ)
 (wcmatch typ "*Dimension")
 (eq "AcDbHatch" typ)
 (eq "AcDbSolid" typ)
 (eq "AcDbTrace" typ)
 (eq "AcDbMLeader" typ)
 (eq trimobj x)
 )
 )
 lst
)
 )
 (ZoomToPointList WCStrimobjpts)
 (foreach x lst
(if (not (vlax-erased-p x))
 (progn
 (setq typ (vlax-get x 'ObjectName))
 (cond
 ((and
 (eq "AcDbPolyline" typ)
 (= -1 (vlax-get x 'Closed))
 )
 (vlax-put x 'Closed 0)
 (setq coord (vlax-get x 'Coordinates))
 (vlax-put x 'Coordinates
 (append coord (list (car coord) (cadr coord)))
 )
 (vla-update x)
 )
 ((and
 (eq "AcDb2dPolyline" typ)
 (= -1 (vlax-get x 'Closed))
 )
 (vlax-put x 'Closed 0)
 (setq coord (vlax-get x 'Coordinates))
 (vlax-put x 'Coordinates
 (append coord (list (car coord) (cadr coord) (caddr coord)))
 )
 (vla-update x)
 )
 )
 )
)
(if (setq intpts (GetInters offsetobj x acExtendNone))
 (progn
 (if (> (length intpts) 2)
 (setq intpts (SortInterPoints x intpts))
 )
 (foreach p intpts
 (setq mark (entlast))
 (if
 (and
 (not (vl-catch-all-error-p
 (vl-catch-all-apply 'vlax-curve-getParamAtPoint (list x p)))
 )
 (vlax-curve-getParamAtPoint x p)
 )
 (vl-cmdf "._trim" trimename ""
 (list (vlax-vla-object->ename x) (trans p 0 1)) "")
 )
 (if (not (eq mark (entlast)))
 (setq postlst (cons (entlast) postlst))
 )
 )
 )
)
 )
 (while postlst
(setq intpts nil)
(foreach x postlst
 (if (setq intpts (GetInters offsetobj x acExtendNone))
 (progn
 (if (> (length intpts) 2)
 (setq intpts (SortInterPoints x intpts))
 )
 (foreach p intpts
 (setq mark nil)
 (setq mark (entlast))
 (if
 (and
 (not (vl-catch-all-error-p
 (vl-catch-all-apply 'vlax-curve-getParamAtPoint (list x p)))
 )
 (vlax-curve-getParamAtPoint x p)
 )
 (vl-cmdf "._trim" trimename "" (list x (trans p 0 1)) "")
 )
 (setq postlst (vl-remove x postlst))
 (if (not (eq mark (entlast)))
 (setq postlst (cons (entlast) postlst))
 )
 )
 (setq postlst (vl-remove x postlst))
 )
 (setq postlst (vl-remove x postlst))
 )
)
 )
 (if
(and
 (eq "Yes" delother)
 trimobj
 offsetobj
 (not (GetInters offsetobj trimobj acExtendNone))
)
(cond
 ((and
 (eq side "inside")
 (setq WCSoffsetobjpts (TraceObject offsetobj))
 (setq UCSoffsetobjpts
 (mapcar '(lambda (x) (trans x 0 1)) WCSoffsetobjpts)
 )
 )
 (if (setq sstest (ssget "_cp" UCSoffsetobjpts))
 (command "._erase" sstest "")
 )
 )
 ((eq side "outside")
 (setq mark (entlast))
 (vl-cmdf "._offset" (* d 3) offsetename UCSpkpt "_exit")
 (if
 (and
 (not (eq mark (setq testename (entlast))))
 (not (GetInters testename trimobj acExtendNone))
 (setq WCSoffsetobjpts (TraceObject testename))
 (setq UCSoffsetobjpts
 (mapcar '(lambda (x) (trans x 0 1)) WCSoffsetobjpts)
 )
 )
 (progn
 (setq sskeep (ssget "_wp" UCSoffsetobjpts))
 (vlax-invoke *acad* 'ZoomExtents)
 (setq sc (GetScreenCoords)
 minpt (car sc)
 maxpt (cadr sc)
 sstest (ssget "_c" minpt maxpt)
 i 0
 )
 (if
 (and
 sskeep
 sstest
 (> (sslength sstest) (sslength sskeep))
 )
 (repeat (sslength sstest)
 (setq e (ssname sstest i))
 (if (not (ssmemb e sskeep))
 (entdel e)
 )
 (setq i (1+ i))
 )
 )
 )
 )
 )
)
 )
 (command "._zoom" "_window" (car curcoord) (cadr curcoord))
 (*error* nil)
)
[/pcode]

xvjiex · 发表于 2022-4-26 00:03:03

感谢楼主分享！

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

[每日一码] 【方案讨论】用于CAD2006以下版本的框选剪切与延伸----方案1

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评

点评

点评

点评

评分