Author Topic: Purge obsolete modelspace geometry  (Read 1826 times)

0 Members and 1 Guest are viewing this topic.

qwrtz

  • Newt
  • Posts: 22
Purge obsolete modelspace geometry
« on: December 28, 2015, 12:40:02 PM »
I have to work on files created by coworkers who never delete anything and never start a new dwg file. The model tab always has a lot of geometry left over from previous projects, including dozens of obsolete external references using absolute paths to files on the server or on someone else's hard drive.

The projects are all pretty similar, so I can't tell what's obsolete and what's current except by marking everything that's shown in a viewport. So I draw a rectangle as large as possible in each viewport in each layout tab, using a thick lineweight and a distinctive color. Then I switch to the model tab and delete anything that doesn't have a rectangle of that color and lineweight around it.

Drawing the rectangles takes 10 or 15 minutes per file, and it's very boring work. But it feels like something that a lisp function could do in a few seconds. And it occurs to me that I'm not the first person who's had to deal with cluttered files. Does anyone know of a lisp function that does that or something similar?

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: Purge obsolete modelspace geometry
« Reply #1 on: December 28, 2015, 06:25:17 PM »
This will draw the rectangle for you: Viewport Outline

mailmaverick

  • Bull Frog
  • Posts: 494
Re: Purge obsolete modelspace geometry
« Reply #2 on: January 01, 2016, 09:46:01 AM »
I have made a LISP routing which automatically deletes all objects in MODEL which are not part of any Viewport in any Layout. Please see if it suits your requirement.
Code: [Select]
(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 PCS2WCS (pnt ent / ang enx mat nor scl)
    ;; PCS2WCS (gile)
    ;; Translates a PCS point to WCS based on the supplied Viewport
    ;; (PCS2WCS pt vp) is the same as (trans (trans pt 3 2) 2 0) when vp is active
    ;; pnt : PCS point
    ;; ent : Viewport ename
    (setq pnt (trans pnt 0 0)
          enx (entget ent)
          ang (- (cdr (assoc 51 enx)))
          nor (cdr (assoc 16 enx))
          scl (/ (cdr (assoc 45 enx)) (cdr (assoc 41 enx)))
          mat (mxm (mapcar (function (lambda (v) (trans v 0 nor t))) '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0)))
                   (list (list (cos ang) (- (sin ang)) 0.0) (list (sin ang) (cos ang) 0.0) '(0.0 0.0 1.0))
              )
    )
    (mapcar '+
            (mxv mat (mapcar '+ (vxs pnt scl) (vxs (cdr (assoc 10 enx)) (- scl)) (cdr (assoc 12 enx))))
            (cdr (assoc 17 enx))
    )
  )
  ;;
  ;;
  (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                              ;;
;;----------------------------------------------------------------------;;



qwrtz

  • Newt
  • Posts: 22
Re: Purge obsolete modelspace geometry
« Reply #3 on: January 04, 2016, 09:39:42 AM »
Thanks very much, Lee Mac and MailMaverick, for these two really amazing and useful lisp functions.

MailMaverick's function goes beyond what I asked for and does exactly what I need to do all in one step. I wouldn't have thought that was possible. It's really something to watch it automatically clean up a big, bloated file and leave it with only the things that should be there. Nice work!

Lee Mac's function does exactly what I asked for. I have to do some manual work with that method, but it gives me the option to leave some objects in modelspace even if they're not in a viewport. Even without wanting to clean up modelspace it's great to have a command that draws a polyline in modelspace to show the limits of the viewport. And it works even with non-rectangular viewports. Excellent!