删除模型空间所有不在布局VIEWPORT内部的实体
(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 - selection prompt
;; arg - 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：
**** Hidden Message ***** 这个标题有点费解呀..
这个好，对图纸交给甲方之前能够用上，谢谢楼主！ q3_2006 发表于 2017-5-15 05:44
图纸空间很多视口范围外的，在模型空间的，这些实体，被删除。
或者说，模型空间里面，没有设置到图纸空间视口内显示的，删除。
感谢楼主分享！！！！！！ 感谢分享源码。 xiankankanzaishuo
回复学习学习！ 感谢分享。。。。。。 谢谢分享。 下载看看对自己是否有用！
必须要顶你 来学习一下 学习一下 感谢分享源码。
页:
[1]
2