框选复制块内的实体

qxlonmsn

;|
框选块内实体
不适用嵌套块
By qxlonmsn
原理:

1.获取块选择集(从右到左框选)
2.获取选择集的选择方式和框选点表
3.炸块
4.新建空选择集,把要复制的实体加入新选择集
5.(ssget "_p")实体加入要删除的选择集
6.原地插入块
7.复制粘贴
8.删除炸块的选择集实体
|;
;                  路径或块名  插入点    xy比例 旋转角度
;(command "_INSERT" "D:\\12.dwg" (getpoint) 1 1 30)


(defun c:kcopy ( / old_osmode ss_b ss ss_delete lst ents lst_fs pt1 pts km xbl ybl xzjd ss_x  ss_copy )
  (vl-load-com)
  (LM:startundo (LM:acdoc));标记撤销的开始位置
  (setq old_osmode (getvar "osmode"));备份捕捉模式
  (setvar "osmode" 0);关闭捕捉

;;ssget有4种选择方式
;;1点选 2框选(从左到右2点矩形[W]或者多边形[WP]【实体全部在内部才选中】) 3窗交(从右到左2点矩形[C]或者多边形[CP]【实体内部或相交就选中】) 4栏选(多段线[F]【实体相交就选中】)
;;而2框选只有全部框中实体才会被选中,就相当于全选块,因此不包含1点选和2框选的方式

  (princ "\n请使用窗交、栏选")
  (if (and
        (setq ss_b (ssget '((0 . "INSERT"))))
      );end and
      (progn
        (setq ss (ssadd));建立空选择集
        (setq ss_delete (ssadd));;建立要删除的空选择集
        (setq lst (ssnamex ss_b));获取选择集的选择方式信息列表
        (setq ents (vl-remove-if '(lambda (x) (< (car x) 0)) lst));包含选择方式的图元表
        (setq lst_fs (vl-remove-if '(lambda (x) (> (car x) 0)) lst));包含选择顺序的点表

              (foreach n ents
                (cond
                  ((= (car n) 3)
                   (setq pt1 (cdr (assoc 10 (entget (cadr n)))));获取块的插入点
                   (setq pt1 (trans pt1 0 1));转换为用户坐标系,避免坐标系改变导致偏差
                   (setq pts (mapcar 'cadr (cdr (car (vl-remove-if '(lambda (x) (/= (car x) (last n))) lst_fs)))));取得点表
                   (setq pts (mapcar '(lambda (x) (trans x 0 1)) pts));全部转换用户坐标系
                   (setq km (cdr (assoc 2 (entget (cadr n)))));获取块名
                   (setq xbl (cdr (assoc 41 (entget (cadr n)))));原x比例
                   (setq ybl (cdr (assoc 42 (entget (cadr n)))));原y比例
                   (setq xzjd (XD::R2D (cdr (assoc 50 (entget (cadr n))))));原旋转角度
                   (command "_EXPLODE" (cadr n));炸块
                   (setq ss_x (ssget "_p"));炸块的选择集
                   (setq ss_copy (ssget "_cp" pts));要复制的选择集
                   (foreach nn (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_copy))) (setq ss (ssadd nn ss)));图元加入新选择集
                   (foreach nn (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_x))) (setq ss_delete (ssadd nn ss_delete)));图元加入要删除的选择集
                   (command "_insert" km
                                  pt1;插入点
                                  xbl;原x比例
                                  ybl;原y比例
                                  xzjd;原旋转角度
                   );原地插入块
                  );end 1

                  ((= (car n) 4)
                   (setq pt1 (cdr (assoc 10 (entget (cadr n)))));获取块的插入点
                   (setq pt1 (trans pt1 0 1));转换为用户坐标系,避免坐标系改变导致偏差
                   (setq pts (mapcar 'cadr (vl-remove-if '(lambda (x) (not (listp x))) n)));取得点表
                   (setq pts (mapcar '(lambda (x) (trans x 0 1)) pts));全部转换用户坐标系
                   (setq km (cdr (assoc 2 (entget (cadr n)))));获取块名
                   (setq xbl (cdr (assoc 41 (entget (cadr n)))));原x比例
                   (setq ybl (cdr (assoc 42 (entget (cadr n)))));原y比例
                   (setq xzjd (XD::R2D (cdr (assoc 50 (entget (cadr n))))));原旋转角度
                   (command "_EXPLODE" (cadr n));炸块
                   (setq ss_x (ssget "_p"));炸块的选择集
                   (setq ss_copy (ssget "_f" pts));要复制的选择集
                   (foreach nn (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_copy))) (setq ss (ssadd nn ss)));图元加入新选择集
                   (foreach nn (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_x))) (setq ss_delete (ssadd nn ss_delete)));图元加入要删除的选择集
                   (command "_insert" km
                                  pt1;插入点
                                  xbl;原x比例
                                  ybl;原y比例
                                  xzjd;原旋转角度
                   );原地插入块
                  );end 2
                );end cond
              );end foreach
        (command "_copyclip" ss "");复制
        (command "_pasteclip" );粘贴实体
        (foreach nn (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_delete))) (entdel nn));删除打散的实体
      );end progn
  );end if


  (LM:endundo (LM:acdoc));标记撤销的结束位置
  (setvar "osmode" old_osmode);还原备份捕捉模式

  (setq *error* err);错误函数
  (princ)
)


;自定义异常错误处理函数-----
(defun *error* (msg)
  (LM:endundo (LM:acdoc));;标记撤销的结束位置
  (setvar "osmode" old_osmode);还原备份捕捉模式
  (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
      (princ (strcat "\nError: " msg))
  ) ;_ 结束if
  (princ)
) ;_ 结束defun
;自定义异常错误处理函数-----

;;标记开始和结束---------------------------标记开始和结束
;;函数名称:        LM:endundo
;;调用格式:        (LM:endundo (LM:acdoc))
;;参数说明:        
;;(LM:acdoc) ---- (vla-get-activedocument (vlax-get-acad-object))
;;返回值:        t
;;函数简介:        建立UNDO结束标记
;; End Undo  -  Lee Mac
;; Closes an Undo Group.
;;标记结束用法  (LM:endundo (LM:acdoc))
(defun LM:endundo (doc)
  (vl-load-com)
  (while (= 8 (logand 8 (getvar 'undoctl)))
    (vla-endundomark doc)
  ) ;_ 结束while
) ;_ 结束defun

;;函数名称:        LM:startundo
;;调用格式:        (LM:startundo (LM:acdoc))
;;参数说明:        
;;(LM:acdoc) ---- (vla-get-activedocument (vlax-get-acad-object))
;;返回值:        t
;;函数简介:        建立UNDO开始标记
;; Start Undo  -  Lee Mac
;; Opens an Undo Group.
;;标记开始用法  (LM:startundo (LM:acdoc))
(defun LM:startundo (doc)
  (vl-load-com)
  (LM:endundo doc)
  (vla-startundomark doc)
) ;_ 结束defun

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
  (eval (list 'defun
                'LM:acdoc
                'nil
                (vla-get-activedocument (vlax-get-acad-object))
          ) ;_ 结束list
  ) ;_ 结束eval
  (vl-load-com)
  (LM:acdoc)
) ;_ 结束defun
;;标记开始和结束---------------------------标记开始和结束

;弧度转角度
(defun XD::R2D (ang)
  (* 180 (/ ang Pi))
)

(princ "\n启动命令:kcopy")

LXH刚开始

实用插件，感谢分享，

hbabc

感谢楼主分享！！！

hh_lj007

感谢楼主分享！！！

sammy_crysis

好东西，赞赞赞！！！

tigcat

谢谢楼主分享

at1636

学习学习

hbabc

再来顶一下！！！

czb203

感谢楼主分享！！！