Thanks Ron and Tim
Here is the routine where it is used to make CAD file backgrounds for a consultant.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:LayerTableSearch (layername)
(if (tblsearch "LAYER" layername)
(ARCH:DeleteLayer layername)
)
)
(defun ARCH:BlockTableSearch (blockname)
(if (tblsearch "BLOCK" blockname)
(ARCH:DeleteBlockName blockname)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:DeleteLayer (layer_name / ent acapp acsp adoc allrs layer_name TotalNumber
CurrNumber)
(vl-load-com)
(setq acapp (vlax-get-acad-object)
adoc (vla-get-activedocument acapp)
acsp (vla-get-block (vla-get-activelayout adoc))
allrs (vla-get-layers adoc))
(setq TotalNumber
(sslength (ssget "_X" (list (cons 8 layer_name))))
CurrNumber 1)
(or (eq (vla-get-freeze (vla-item allrs layer_name)) :vlax-true)
(vla-put-freeze (vla-item allrs layer_name) :vlax-false))
(or (eq (vla-get-lock (vla-item allrs layer_name)) :vlax-true)
(vla-put-lock (vla-item allrs layer_name) :vlax-false))
(or (eq (vla-get-layeron (vla-item allrs layer_name)) :vlax-false)
(vla-put-layeron (vla-item allrs layer_name) :vlax-true))
(vlax-for
lt (vla-get-layouts adoc)
(vlax-for
ob (vla-get-block lt)
(if (eq (vla-get-layer ob) layer_name)
(progn (vla-delete ob)
(vlax-release-object ob)))))
;;(command "purge" "LA" layer_name "no")
(vla-purgeall (vla-get-activedocument (vlax-get-acad-object)))
(princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:DeleteBlockName (name / Ent EntData )
(if (setq Ent (tblobjname "block" name))
(progn
(setq EntData (entget Ent))
(setq Ent (cdr (assoc 330 EntData)))
(setq EntData (entget Ent))
(foreach i (member '(102 . "{BLKREFS") EntData)
(if
(and
(equal (type (cdr i)) 'ENAME)
(not (vlax-erased-p (cdr i)))
)
(vla-Delete (vlax-ename->vla-object (cdr i)))
)
)
)
)
)
(defun ARCH:DeleteBLOCKS-original (/ i ss ent)
(if (setq i -1 ss (ssget "_X" '((0 . "INSERT") (2 . "ADA*,FND-*,FLR-*,RF-*,*NOTES,*GRID*,*DATE,*ENTRY"))))
(while (setq ent (ssname ss (setq i (1+ i)))) (entdel ent))
)
)
(defun ARCH:DeleteBLOCKS (/ i ss ent)
(if (setq i -1 ss (ssget "_X" '((0 . "INSERT") (2 . "ADA*,FND-*,FLR-*,RF-*,*NOTES,*GRID*,*DATE,*ENTRY"))))
(while (setq ent (ssname ss (setq i (1+ i))))
(vl-catch-all-apply 'vla-delete (list (vlax-ename->vla-object ent)))
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:ThwOnUnlock (/ lyr lyrList)
(setq lyr (tblnext "layer" 'T))
(while lyr
(if (not (zerop (logand (cdr (assoc 70 lyr)) 1)))
(setq lyrList (cons (cdr (assoc 2 lyr)) lyrList)))
(setq lyr (tblnext "layer")))
(progn (setvar "cmdecho" 0)
(command ".layer" "on" "*" "")
(command ".layer" "thaw" "*" "")
(command ".layer" "unlock" "*" "")
)
;;(princ "\n* All Layers have been THAWED, TURNED ON and UNLOCKED *")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:FrzOff (/ lyr lyrList)
(setq lyr (tblnext "layer" 'T))
(while lyr
(if (not (zerop (logand (cdr (assoc 70 lyr)) 1)))
(setq lyrList (cons (cdr (assoc 2 lyr)) lyrList)))
(setq lyr (tblnext "layer")))
(progn (setvar "cmdecho" 0)
(command ".layer" "off" "*" "")
(command ".layer" "freeze" "*" "")
)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:ExplodeBLDG (/ i ss ent obj)
(if (setq i -1 ss (ssget "_X" '((0 . "INSERT") (2 . "BL*"))))
(while (setq ent (ssname ss (setq i (1+ i))))
(and (not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-explode
(list (setq obj (vlax-ename->vla-object ent))))))
(vla-delete obj)))))
(defun ARCH:ExplodeUNIT (/ i ss ent obj)
(if (setq i -1 ss (ssget "_X" '((0 . "INSERT") (2 . "UT*"))))
(while (setq ent (ssname ss (setq i (1+ i))))
(and (not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-explode
(list (setq obj (vlax-ename->vla-object ent))))))
(vla-delete obj)))))
(defun ARCH:ExplodewASHDRY (/ i ss ent obj)
(if (setq i -1 ss (ssget "_X" '((0 . "INSERT") (2 . "PN-WASHDRY"))))
(while (setq ent (ssname ss (setq i (1+ i))))
(and (not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-explode
(list (setq obj (vlax-ename->vla-object ent))))))
(vla-delete obj)))))
(defun ARCH:ExplodeBLOCKS (/ i ss ent obj)
(if (setq i -1 ss (ssget "_X" '((0 . "INSERT") (2 . "Elev*,A$*,PN-Mail2,PN-EP,PN-WCONN,PN-DCONN,MC-PN,TB-PN"))))
(while (setq ent (ssname ss (setq i (1+ i))))
(and (not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-explode
(list (setq obj (vlax-ename->vla-object ent))))))
(vla-delete obj)))))
(defun ARCH:ExplodeDRWDW (/ i ss ent obj)
(if (setq i -1 ss (ssget "_X" '((0 . "INSERT") (2 . "DR-*,WD-*"))))
(while (setq ent (ssname ss (setq i (1+ i))))
(and (not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-explode
(list (setq obj (vlax-ename->vla-object ent))))))
(vla-delete obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun CadBackgrounds-it ()
;;(acet-ui-status (strcat "Please WAIT while the program is working!\nThis may take a while.") " Arch Program© : CAD")
(prompt "\n* Please WAIT while the program is working! *")
(acet-ui-status (strcat "CONGRATULATIONS...\nCAD background successfully completed.") " Please WAIT while the program is working!")
(C:00)
(ARCH:ThwOnUnlock)
(setq bt (getvar "bindtype"))
(setvar "bindtype" 1)
(command "-xref" "b" "*")
(ARCH:ExplodeBLDG)
;;(ARCH:ExplodeDRWDW)
(ARCH:ExplodeUNIT)
(command "insert" (strcat "A$C042E4D5F=" ARCH#CUSF "SYMS/" "A$C042E4D5F"))
(command)
(ARCH:ExplodeWASHDRY)
(ARCH:ExplodeBLOCKS)
;|
(ARCH:BlockTableSearch "EF-FAN1")
(ARCH:BlockTableSearch "FloorPlanNotes")
(ARCH:BlockTableSearch "FoundatioNotes")
(ARCH:BlockTableSearch "Ada-4830")
(ARCH:BlockTableSearch "Ada-6060")
(ARCH:BlockTableSearch "Ada-hc")
(ARCH:BlockTableSearch "SYMENTRY")
(ARCH:BlockTableSearch "SHT_GRID")
(ARCH:BlockTableSearch "ISSUEDATE")
(ARCH:BlockTableSearch "FLR-SYMS2")
(ARCH:BlockTableSearch "FND-SYMS3")
(ARCH:BlockTableSearch "RF-SYMS2")
(ARCH:BlockTableSearch "AMPCORV")
(ARCH:BlockTableSearch "PN-ACESDRS")
|;
(ARCH:DeleteBLOCKS)
(ARCH:LayerTableSearch "A-DIMS")
(ARCH:LayerTableSearch "A-PLFL-HIDE")
(ARCH:LayerTableSearch "A-PLFL-PATT")
(ARCH:LayerTableSearch "A-PLFL-NOTE")
(ARCH:LayerTableSearch "A-NOTE")
(ARCH:LayerTableSearch "A-NOTE-LDR")
(ARCH:LayerTableSearch "A-PATT")
(ARCH:LayerTableSearch "A-REVS-CLOD")
(ARCH:LayerTableSearch "A-REVS-SYMB")
(ARCH:LayerTableSearch "A-SHTT-DATA")
(ARCH:LayerTableSearch "A-SYMB")
(ARCH:LayerTableSearch "A-SYMB-DOOR")
(ARCH:LayerTableSearch "A-SYMB-LBRK")
(ARCH:LayerTableSearch "A-SYMB-MARK")
(ARCH:LayerTableSearch "A-SYMB-MTCH")
(ARCH:LayerTableSearch "A-SYMB-PART")
(ARCH:LayerTableSearch "A-SYMB-ROOM")
(ARCH:LayerTableSearch "A-SYMB-WDW")
(ARCH:LayerTableSearch "LS-2HF")
(ARCH:LayerTableSearch "A-AREA")
(ARCH:LayerTableSearch "A-AREA-GROS")
(ARCH:LayerTableSearch "A-AREA-NET")
(ARCH:LayerTableSearch "A-ALT-WIND-D")
(ARCH:LayerTableSearch "A-ALT-WIND-3")
(ARCH:LayerTableSearch "A-FURN")
(ARCH:LayerTableSearch "A-HC")
(ARCH:LayerTableSearch "A-PATT-POCH")
(ARCH:LayerTableSearch "A-SYMB-IDEN")
(ARCH:LayerTableSearch "A-WALL-PATT")
(ARCH:LayerTableSearch "E-POWR-NOTE")
(ARCH:LayerTableSearch "S-COLS-GRID")
(ARCH:LayerTableSearch "A-EXIT-TEXT")
(ARCH:LayerTableSearch "E-POWR-NOTE")
(ARCH:LayerTableSearch "X-REDL")
(ARCH:LayerTableSearch "JUNK")
(ARCH:LayerTableSearch "DEFPOINTS")
(ARCH:FrzOff "A-DOOR-CODE")
(ARCH:FrzOff "A-CLNG-HEAD")
(vla-purgeall (vla-get-activedocument (vlax-get-acad-object)))
;;(C:XS)
(setvar "bindtype" bt)
(princ "\n* CAD background successfully completed... *")
;;(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun CadBackgroundsit (/ result)
(setq Result (ARCH:QUESTION-5
"Create CAD Backgrounds"
" Warning this will Bind, Explode and Purge ALL Xrefs.\n"
" Make sure this is NOT the Original Drawing!!!\n\n"
" [ 1 ]\t to continue on...\n" " [ 2 ]\t to cancel." ""))
(cond ((= 0 Result) (CadBackgrounds-it))
((= 1 Result)
(princ "\n*** ///////// Program CANCELLED ///////// ***")))
(princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ)