删除模型空间所有不在布局VIEWPORT内部的实体

Lisphk · 发表于 2017-5-14 22:37:57

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

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

×

(defun c:DelObjNotinViewports (/ A ACDOC CEN ENT FFGG LST M N NOR OCS OLDORTHOMODE OLDOSMODE OLDSNAPMODE R S SSDELETE SSET SSETALL SSVP STRMSG V VERTICES VPE VPNM VPT X)
(vl-load-com)
;;----------------------------------------------------------------------;;
;; Function Definitions ;;
;;----------------------------------------------------------------------;;
(defun kdub:ssunion (ss1 ss2 / ss index)
;; Union of two selection sets
;; Source : http://www.theswamp.org/index.php?topic=46652.0
(setq ss (ssadd))
(cond ((and ss1 ss2)
(setq index -1)
(repeat (sslength ss1) (ssadd (ssname ss1 (setq index (1+ index))) ss))
(setq index -1)
(repeat (sslength ss2) (ssadd (ssname ss2 (setq index (1+ index))) ss))
)
(ss1 (setq ss ss1))
(ss2 (setq ss ss2))
(t (setq ss nil))
)
ss
)
;;
;;
(defun kdub:sssubtract (ss1 ss2 / ss)
;; Subtracts one selection set from another and returns their difference
;; Source : http://www.theswamp.org/index.php?topic=46652.0
(cond ((and ss1 ss2) (vl-cmdf "._Select" ss1 "_Remove" ss2 "") (setq ss (ssget "_P")))
(ss1 (setq ss ss1))
(t (setq ss nil))
)
ss
)
;;
;;
(defun vpo:lwvertices (e)
(if (setq e (member (assoc 10 e) e))
(cons (cons (cdr (assoc 10 e)) (assoc 42 e)) (vpo:lwvertices (cdr e)))
)
)
;;
;;
(defun LM:ssget (msg arg / sel)
;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel))
sel
)
)
;;
;;
;;
;;
(defun trp (m)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(apply 'mapcar (cons 'list m))
)
;;
;;
(defun mxm (m n)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
((lambda (a) (mapcar '(lambda (r) (mxv a r)) m)) (trp n))
)
;;
;;
(defun mxv (m v)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
;;
;;
(defun vxs (v s)
;; Vector x Scalar - Lee Mac
;; Args: v - vector in R^n, s - real scalar
(mapcar '(lambda (n) (* n s)) v)
)
;;
;;
(defun LM:startundo (doc)
;; Start Undo - Lee Mac
;; Opens an Undo Group.
(LM:endundo doc)
(vla-startundomark doc)
)
;;
;;
(defun LM:endundo (doc)
;; End Undo - Lee Mac
;; Closes an Undo Group.
(while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc))
)
;;
;;
(defun LM:acdoc nil
;; Active Document - Lee Mac
;; Returns the VLA Active Document Object
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
;;
;;
;;----------------------------------------------------------------------;;
;; Actual Program Started ;;
;;----------------------------------------------------------------------;;
(LM:startundo (LM:acdoc))
(setq oldsnapmode (getvar "snapmode"))
(setq oldosmode (getvar "osmode"))
(setq oldorthomode (getvar "orthomode"))
(setvar "snapmode" 0)
(setvar "osmode" 0)
(setvar "orthomode" 0)
(setq sset (ssadd))
(setq acdoc (LM:acdoc))
(setvar 'ctab "MODEL")
;; Zoom Extents is required so that ssget _CP works properly.
(command "ZOOM" "E")
(vlax-for vlayout (vla-get-layouts acdoc)
(vla-put-ActiveLayout acdoc vlayout)
(setq vpnm (strcase (vla-get-Name vlayout)))
(if (not (equal vpnm "MODEL"))
(progn (setq ssvp (ssget "_A" (list (cons 0 "VIEWPORT") (cons 410 vpnm))))
(repeat (setq n (sslength ssvp))
(setq vpt (entget (ssname ssvp (setq n (1- n)))))
(if (setq ent (cdr (assoc 340 vpt)))
(setq lst (vpo:lwvertices (entget ent)))
(setq cen (mapcar 'list (cdr (assoc 10 vpt)) (list (/ (cdr (assoc 40 vpt)) 2.0) (/ (cdr (assoc 41 vpt)) 2.0)))
lst (mapcar '(lambda (a) (cons (mapcar 'apply a cen) '(42 . 0.0))) '((- -) (+ -) (+ +) (- +)))
)
)
(setq vpe (cdr (assoc -1 vpt))
ocs (cdr (assoc 16 vpt))
)
(setq vertices (apply 'append
(mapcar '(lambda (x) (setq ffgg (trans (pcs2wcs (car x) vpe) 0 ocs)) (list (list (car ffgg) (cadr ffgg))))
lst
)
)
)
(setvar 'ctab "MODEL")
(setq sset (kdub:ssunion sset (ssget "_CP" vertices (list (cons 410 "Model")))))
)
)
)
)
(cond (sset
(setq countsset (sslength sset))
(setvar 'ctab "MODEL")
(setq ssetall (ssget "_A" (list (cons 410 "Model"))))
(cond (ssetall
(setq countssetall (sslength ssetall))
(setq countdel (- countssetall countsset))
(setq strmsg (strcat "Found "
(itoa countsset)
" objects which are part of viewports."
"\nFound "
(itoa countssetall)
" total objects in MODEL."
"\nDeleting "
(itoa countssetall)
" - "
(itoa countsset)
" objects = "
(itoa countdel)
" objects from MODEL.\n"
)
)
(setq ssdelete (kdub:sssubtract ssetall sset))
(command "erase" ssdelete "")
)
(T (setq strmsg "No objects found in MODEL to be deleted.\n"))
)
)
(T (setq strmsg "No objects found which are present in MODEL and in Viewports.\n"))
)
(princ (strcat "\n\n" strmsg "\n\n"))
(alert strmsg)
(setvar "snapmode" oldsnapmode)
(setvar "orthomode" oldorthomode)
(setvar "osmode" oldosmode)
(LM:endundo acdoc)
(princ)
)
;;----------------------------------------------------------------------;;
(princ (strcat "\n\n\n:: Deletes all Objects which are not in any Viewport in any Layout "
"\n:: Thanks to Lee Mac, Gile, Kerry (KDUB), Vladimir Nesterovsky and Doug Wilson"
"\n:: Type \"DelObjNotinViewports\" to Invoke ::"
)
)
(princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;

(defun c:DelObjNotinViewports (/ A ACDOC CEN ENT FFGG LST M N NOR OCS OLDORTHOMODE OLDOSMODE OLDSNAPMODE R S SSDELETE SSET SSETALL SSVP STRMSG V VERTICES VPE VPNM VPT X) 
  (vl-load-com) 
  ;;----------------------------------------------------------------------;; 
  ;;                         Function Definitions                         ;; 
  ;;----------------------------------------------------------------------;; 
  (defun kdub:ssunion (ss1 ss2 / ss index) 
    ;; Union of two selection sets 
    ;; Source : <a href=\"http://www.theswamp.org/index.php?topic=46652.0\" target=\"_blank\">http://www.theswamp.org/index.php?topic=46652.0</a> 
    (setq ss (ssadd)) 
    (cond ((and ss1 ss2) 
           (setq index -1) 
           (repeat (sslength ss1) (ssadd (ssname ss1 (setq index (1+ index))) ss)) 
           (setq index -1) 
           (repeat (sslength ss2) (ssadd (ssname ss2 (setq index (1+ index))) ss)) 
          ) 
          (ss1 (setq ss ss1)) 
          (ss2 (setq ss ss2)) 
          (t (setq ss nil)) 
    ) 
    ss 
  ) 
  ;; 
  ;; 
  (defun kdub:sssubtract (ss1 ss2 / ss) 
    ;; Subtracts one selection set from another and returns their difference 
    ;; Source : <a href=\"http://www.theswamp.org/index.php?topic=46652.0\" target=\"_blank\">http://www.theswamp.org/index.php?topic=46652.0</a> 
    (cond ((and ss1 ss2) (vl-cmdf "._Select" ss1 "_Remove" ss2 "") (setq ss (ssget "_P"))) 
          (ss1 (setq ss ss1)) 
          (t (setq ss nil)) 
    ) 
    ss 
  ) 
  ;; 
  ;; 
  (defun vpo:lwvertices (e) 
    (if (setq e (member (assoc 10 e) e)) 
      (cons (cons (cdr (assoc 10 e)) (assoc 42 e)) (vpo:lwvertices (cdr e))) 
    ) 
  ) 
  ;; 
  ;; 
  (defun LM:ssget (msg arg / sel) 
    ;; ssget  -  Lee Mac 
    ;; A wrapper for the ssget function to permit the use of a custom selection prompt 
    ;; msg - [str] selection prompt 
    ;; arg - [lst] list of ssget arguments 
    (princ msg) 
    (setvar 'nomutt 1) 
    (setq sel (vl-catch-all-apply 'ssget arg)) 
    (setvar 'nomutt 0) 
    (if (not (vl-catch-all-error-p sel)) 
      sel 
    ) 
  ) 
  ;; 
  ;; 
   
  ;; 
  ;; 
  (defun trp (m) 
    ;; Matrix Transpose  -  Doug Wilson 
    ;; Args: m - nxn matrix 
    (apply 'mapcar (cons 'list m)) 
  ) 
  ;; 
  ;; 
  (defun mxm (m n) 
    ;; Matrix x Matrix  -  Vladimir Nesterovsky 
    ;; Args: m,n - nxn matrices 
    ((lambda (a) (mapcar '(lambda (r) (mxv a r)) m)) (trp n)) 
  ) 
  ;; 
  ;; 
  (defun mxv (m v) 
    ;; Matrix x Vector  -  Vladimir Nesterovsky 
    ;; Args: m - nxn matrix, v - vector in R^n 
    (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m) 
  ) 
  ;; 
  ;; 
  (defun vxs (v s) 
    ;; Vector x Scalar  -  Lee Mac 
    ;; Args: v - vector in R^n, s - real scalar 
    (mapcar '(lambda (n) (* n s)) v) 
  ) 
  ;; 
  ;; 
  (defun LM:startundo (doc) 
    ;; Start Undo  -  Lee Mac 
    ;; Opens an Undo Group. 
    (LM:endundo doc) 
    (vla-startundomark doc) 
  ) 
  ;; 
  ;; 
  (defun LM:endundo (doc) 
    ;; End Undo  -  Lee Mac 
    ;; Closes an Undo Group. 
    (while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc)) 
  ) 
  ;; 
  ;; 
  (defun LM:acdoc nil 
    ;; Active Document  -  Lee Mac 
    ;; Returns the VLA Active Document Object 
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) 
    (LM:acdoc) 
  ) 
  ;; 
  ;; 
  ;;----------------------------------------------------------------------;; 
  ;;                         Actual Program Started                       ;; 
  ;;----------------------------------------------------------------------;; 
  (LM:startundo (LM:acdoc)) 
  (setq oldsnapmode (getvar "snapmode")) 
  (setq oldosmode (getvar "osmode")) 
  (setq oldorthomode (getvar "orthomode")) 
  (setvar "snapmode" 0) 
  (setvar "osmode" 0) 
  (setvar "orthomode" 0) 
  (setq sset (ssadd)) 
  (setq acdoc (LM:acdoc)) 
  (setvar 'ctab "MODEL") 
  ;; Zoom Extents is required so that ssget _CP works properly. 
  (command "ZOOM" "E") 
  (vlax-for vlayout (vla-get-layouts acdoc) 
    (vla-put-ActiveLayout acdoc vlayout) 
    (setq vpnm (strcase (vla-get-Name vlayout))) 
    (if (not (equal vpnm "MODEL")) 
      (progn (setq ssvp (ssget "_A" (list (cons 0 "VIEWPORT") (cons 410 vpnm)))) 
             (repeat (setq n (sslength ssvp)) 
               (setq vpt (entget (ssname ssvp (setq n (1- n))))) 
               (if (setq ent (cdr (assoc 340 vpt))) 
                 (setq lst (vpo:lwvertices (entget ent))) 
                 (setq cen (mapcar 'list (cdr (assoc 10 vpt)) (list (/ (cdr (assoc 40 vpt)) 2.0) (/ (cdr (assoc 41 vpt)) 2.0))) 
                       lst (mapcar '(lambda (a) (cons (mapcar 'apply a cen) '(42 . 0.0))) '((- -) (+ -) (+ +) (- +))) 
                 ) 
               ) 
               (setq vpe (cdr (assoc -1 vpt)) 
                     ocs (cdr (assoc 16 vpt)) 
               ) 
               (setq vertices (apply 'append 
                                     (mapcar '(lambda (x) (setq ffgg (trans (pcs2wcs (car x) vpe) 0 ocs)) (list (list (car ffgg) (cadr ffgg)))) 
                                             lst 
                                     ) 
                              ) 
               ) 
               (setvar 'ctab "MODEL") 
               (setq sset (kdub:ssunion sset (ssget "_CP" vertices (list (cons 410 "Model"))))) 
             ) 
      ) 
    ) 
  ) 
  (cond (sset 
         (setq countsset (sslength sset)) 
         (setvar 'ctab "MODEL") 
         (setq ssetall (ssget "_A" (list (cons 410 "Model")))) 
         (cond (ssetall 
                (setq countssetall (sslength ssetall)) 
                (setq countdel (- countssetall countsset)) 
                (setq strmsg (strcat "Found " 
                                     (itoa countsset) 
                                     " objects which are part of viewports." 
                                     "\nFound " 
                                     (itoa countssetall) 
                                     " total objects in MODEL." 
                                     "\nDeleting " 
                                     (itoa countssetall) 
                                     " - " 
                                     (itoa countsset) 
                                     " objects = " 
                                     (itoa countdel) 
                                     " objects from MODEL.\n" 
                             ) 
                ) 
                (setq ssdelete (kdub:sssubtract ssetall sset)) 
                (command "erase" ssdelete "") 
               ) 
               (T (setq strmsg "No objects found in MODEL to be deleted.\n")) 
         ) 
        ) 
        (T (setq strmsg "No objects found which are present in MODEL and in Viewports.\n")) 
  ) 
  (princ (strcat "\n\n" strmsg "\n\n")) 
  (alert strmsg) 
  (setvar "snapmode" oldsnapmode) 
  (setvar "orthomode" oldorthomode) 
  (setvar "osmode" oldosmode) 
  (LM:endundo acdoc) 
  (princ) 
) 
 
 
;;----------------------------------------------------------------------;; 
 
(princ (strcat "\n\n\n:: Deletes all Objects which are not in any Viewport in any Layout  " 
               "\n:: Thanks to Lee Mac, Gile, Kerry (KDUB),  Vladimir Nesterovsky and Doug Wilson" 
               "\n:: Type \"DelObjNotinViewports\" to Invoke ::" 
       ) 
) 
(princ) 
 
;;----------------------------------------------------------------------;; 
;;                             End of File                              ;; 
;;----------------------------------------------------------------------;;

函数PCS2WCS：

游客，如果您要查看本帖隐藏内容请回复

q3_2006 · 发表于 2017-5-15 05:44:23

这个标题有点费解呀..

HLCAD · 发表于 2017-5-15 08:07:33

这个好，对图纸交给甲方之前能够用上，谢谢楼主！

newer · 发表于 2017-5-15 08:18:02

q3_2006 发表于 2017-5-15 05:44

图纸空间很多视口范围外的，在模型空间的，这些实体，被删除。
或者说，模型空间里面，没有设置到图纸空间视口内显示的，删除。

sh_h · 发表于 2017-5-15 09:06:42

感谢楼主分享！！！！！！

向嘟嘟 · 发表于 2017-5-15 09:11:33

感谢分享源码。

lzj511 · 发表于 2017-9-27 17:45:14

xiankankanzaishuo

dnbcgrass · 发表于 2017-9-27 22:39:39

回复学习学习！

liunian0524 · 发表于 2017-10-3 16:08:26

感谢分享。。。。。。

kqqt6236 · 发表于 2017-10-5 00:11:13

谢谢分享。

小陶 · 发表于 2018-4-12 23:53:08

下载看看对自己是否有用！

liulisheng · 发表于 2018-4-13 09:37:50

必须要顶你

naruto018 · 发表于 2019-1-8 10:13:53

来学习一下

qyming2000 · 发表于 2019-1-8 18:36:17

学习一下
来自: 微社区

wssczxf · 发表于 2019-1-9 22:16:09

感谢分享源码。

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

[每日一码] 删除模型空间所有不在布局VIEWPORT内部的实体

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

相关帖子