Topic: Base, Move, Purge

[DanB]

This is probably a very basic request for this bunch but I still would like some help. I have a few (100 or so) blocks that were defined "incorrectly." Essentially I need to relocate the "Base" coordinate to 0,0,0 and move all entities to their new corresponding location in the drawing/block. I also would like to set all entities to Layer 0 (zero), color set to bylayer, linetype bylayer, etc. I am very new to LISP and would appreciate any help you may offer. Thanks in advance.

Dan

P.S. I have been browsing this site recently (just found out about you). You guys/gals offer up some great advice, keep up the good work.

[M-dub]

You want to create a script to do this.  I created one here to do exactly what you are describing.  I'll look for it (I may have deleted it after the job was done) and post it if I can find it.  We'll be able to help you anyway though...

[hudster]

Along a very similar line, if I change the base point of a block, when I redefine it in a drawing, how can I stop the block from moving?

[ronjonp]

Use this lisp in a script to change basepoint, color and ltype bylayer, and put everything on layer 0. Plus it will clean up any leftover junk in the drawing (registered apps, empty text, layerfilters,purges, audits, deletes page setups,.....). I recently used http://www.ezscriptpro.com/ to create the script and it works well. Hope this gets you started. As for moving the objects, a simple macro might spped things up greatly:
^C^C.move;all;;\0,0,0;

Code: [Select]

(defun c:ninja (/ TXT NB NAMES BLK lay ent name removed cnt *acad* curdwg pslayout x)
 (command ".base" "0,0,0")
 (command ".chprop"  "all" ""    "color"    "bylayer"
  "ltype"    "bylayer" "layer" "0" ""
 )
  (command ".vbastmt" "thisdrawing.purgeall" ".audit" "y")
  (progn (textscr)
(princ "\n        ***All Objects Set to Color & Linetype Bylayer***")
(princ "\n        ***Drawing Purged***")
(princ "\n        ***Drawing Audited***")
(princ "\n        ***All Layer Filters Deleted***")
(Princ "\n        ***All Layer States Deleted***")
(Princ "\n        ***All Registered Applications Deleted***")
(Princ "\n        ***All Pagesetups Deleted***")
  )

 ;_____________________________________________________________________________
  ;; DELETES ALL LAYER FILTERS
 ;_____________________________________________________________________________

  (vl-Load-Com)
  (vl-Catch-All-Apply
    '(lambda ()
       (vla-Remove
(vla-GetExtensionDictionary
  (vla-Get-Layers
    (vla-Get-ActiveDocument
      (vlax-Get-Acad-Object)
    )
  )
)
"ACAD_LAYERFILTERS"
       )
     )
  )

 ;_____________________________________________________________________________  
  ;; DELETES NUL LINES OF TEXT, MTEXT, AND BLOCKS
 ;_____________________________________________________________________________

  (if (setq TXT (ssget "X"
      '((-4 . "<and")
(-4 . "<or")
(0 . "MTEXT")
(0 . "TEXT")
(-4 . "or>")
(-4 . "<or")
(1 . "")
(1 . " ")
(1 . "  ")
(1 . "   ")
(1 . "{}")
(1 . "{ }")
(1 . "{  }")
(1 . "{   }")
(1 . "{}\P")
(1 . "{ }\P")
(1 . "{  }\P")
(1 . "{   }\P")
(-4 . "or>")
(-4 . "and>")
)
)
      )
    (progn
      (command "_erase" TXT "")
      (princ (strcat "\n  "
    (itoa (sslength TXT))
    " nul text strings deleted. "
    )
      )
    )
    (princ "\n  No nul text strings found. ")
  )

  (setq BLK   (tblnext "BLOCK" T)
NAMES nil
  )
  (while BLK
    (if (= (cdr (assoc 0 (entget (cdr (assoc -2 BLK))))) "ENDBLK")
      (progn
(if (setq NB (ssget "X" (list (assoc 2 BLK))))
 (command "_erase" NB "")
)
(setq NAMES (cons (cdr (assoc 2 BLK)) NAMES))
      )
    )
    (setq BLK (tblnext "BLOCK"))
  )
  (if NAMES
    (progn (textscr)
  (princ "\n  Nul blocks found and need purging: ")
  (foreach X NAMES (princ "\n    ") (princ X))
    )
    (princ "\n  No nul blocks found. ")
  )
  (princ)
)

 ;_____________________________________________________________________________
;;CLEARS ALL LAYER STATES
 ;_____________________________________________________________________________

(
 (lambda (/ lay ent)
   (while (setq lay (tblnext "layer" (not lay)))
     (if (and
  (setq
    ent (entget (tblobjname "layer" (cdr (assoc 2 lay)))
'("RAK")
)
  )
  (assoc -3 ent)
)
       (entmod (subst '(-3 ("RAK")) (assoc -3 ent) ent))
     )
   )
 )
)

;_____________________________________________________________________________
;;DELETES REGISTERED APPLICATIONS EXCEPT FOR WID*
;____________________________________________________________________________
 
  (vl-load-com)
  (setq cnt 0)
  (if (not *acad*)
    (setq *acad* (vlax-get-acad-object))
  )
  (setq allapp (vla-get-registeredapplications
(vla-get-activedocument *acad*)
      )
  ) ;(setq name nil)
  (vlax-for app allapp
;(setq name (append name (list (vla-get-name app)))))
    (setq name (vla-get-name app))
    (cond ((or
    (not (wcmatch (strcase name) (strcase "WID*")))
  )
  (if
    (not
      (vl-catch-all-error-p
(vl-catch-all-apply
  'vla-delete
  (list app)
)
      )
    )
     (progn
(setq cnt (1+ cnt))
(setq removed
      (princ
(strcat
  "\nRemoved application \""
  name
  "\""
)
      )
)
     ) ;end progn
  )
  (if (not removed)
    (princ "\nNo applications were removable.")
    (print cnt)
  )
 )
    )
  )
  (princ)
  (setq name nil
removed nil
cnt nil
allapp nil
  )

;_____________________________________________________________________________
;;DELETES ALL PAGESETUPS
;_____________________________________________________________________________

(vl-load-com)
(setq
  curdwg   (vla-get-ActiveDocument (vlax-get-Acad-Object))
  pslayout (vla-get-Layout (vla-get-PaperSpace curdwg))
) ;_ end of setq
;; Call RefreshPlotDeviceInfo before GetPlotDeviceNames
(vla-RefreshPlotDeviceInfo pslayout)
(vlax-for x (vla-get-Plotconfigurations curdwg)
  (vla-delete x)
) ;_ end of vlax-for
(c:ninja)



[DanB]

I have worked with and written some Script Routines in the past. How is it that I can extract the current Base point location to be used in the Move command?

Dan

[DanB]

Great! Thanks I will give this a try when I get a few minutes.

Thanks Again.

Dan

[ronjonp]

Try this macro for setting the basepoint.

.zoom;extents;^C^C.MOVE;ALL;;(GETVAR "VIEWCTR");0,0,0;BASE;0,0,0;.zoom;extents;

[M-dub]

Actually, I just remembered how I had it work...
It was only a macro because I wanted to physically pick the new basepoint myself.  Basically, it was something like this:

Code: [Select]

^C^Cmove;all;;\0,0;base;0,0;z;e;change;all;;p;c;bylayer;la;0;lt;bylayer;;-layer;s;0;;-purge;a;;n;

Give it a try and let me know if it works or not....

*Note that there is no QSAVE in the macro...it's just a test.

[M-dub]

oops...looks like I was a little too slow...

Ah well...I'm sure that at least one of those options will work for you!


BTW, Welcome to The Swamp!