a Lisp for Dave C.

here you go dave.

(defun curge (/ all_blocks keep_block thisdwg block1 all_dimstyles keep_dimstyles dimstyle all_layers keep_layers layer2 all_tstyles keep_tstyles tstyle all_ltypes keep_ltype ltype curlay)
;(princ "\nStarting purge")
(setvar "cmdecho" 0)
;;;Block Purge
(setq all_blocks (mapcar (function (lambda (i) (strcase i)))(ai_table "block" 0)))
(setq keep_block (mapcar 'strcase (list "NA" "_archtick" )))
(or thisdwg (setq thisdwg (vla-get-activedocument (vlax-get-acad-object))))
(foreach blockname all_blocks
(if (not (or (vl-position blockname keep_block) (= (substr blockname 1 2) "*D" )))
(if (not (vl-catch-all-error-p (setq block1 (vl-catch-all-apply 'vla-item (list (vla-get-blocks thisdwg) blockname)))))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list block1)))))))
;;;Dimension Purge
(setvar "cmdecho" 0)
(setq all_dimstyles (mapcar (function (lambda (i) (strcase i)))(ai_table "dimstyle" 0)))
(setq dimset (CDR (ASSOC 1 (dictsearch (namedobjdict) "XRECLIST"))))
(setq keep_dimstyles (list "1-16'' - 1FT" "3-32'' - 1FT" "1-8'' - 1FT" "3-16'' - 1FT" "1-4'' - 1FT" "3-8'' - 1FT" "1-2'' - 1FT" "3-4'' - 1FT" "1'' - 1FT" "1 1-2'' - 1FT" "2'' - 1FT" "3'' - 1FT" "6'' - 1FT" "1'' - 1''" "1'' - 10FT" "1'' - 20FT" "1'' - 30FT" "1'' - 40FT" "1'' - 50FT" "1'' - 70FT" "1'' - 75FT" "1'' - 80FT" "1'' - 100FT" "1'' - 120FT" "1'' - 150FT" "1'' - 200FT" "1'' - 300FT" "1'' - 400FT" "1'' - 500FT" "1'' - 1000FT"))
(or thisdwg (setq thisdwg (vla-get-activedocument (vlax-get-acad-object))))
(foreach dimname all_dimstyles
(if (not (vl-position dimname keep_dimstyles))
(if (not (vl-catch-all-error-p (setq dimstyle (vl-catch-all-apply 'vla-item (list (vla-get-dimstyles thisdwg) dimname)))))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list dimstyle)))))))
;;;Layer Purge
(setq all_layers (mapcar (function (lambda (i) (strcase i)))(ai_table "layer" 0)))
(setq keep_layers (mapcar 'strcase (list "text" "pl" "el" "contours" "ant" "steel" "eq" "ha" "grid" "tray" "gnd" "power" "bolts" "fence" "vp" "0")))
(or thisdwg (setq thisdwg (vla-get-activedocument (vlax-get-acad-object))))
(foreach layname all_layers
(if (not (vl-position layname keep_layers))
(if (not (vl-catch-all-error-p (setq layer2 (vl-catch-all-apply 'vla-item (list (vla-get-layers thisdwg) layname)))))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list layer2)))))))
;;;Text Style Purge
(setq all_tstyles (mapcar (function (lambda (i) (strcase i)))(ai_table "style" 0)))
(setq keep_tstyles (list "Nothing"))
(or thisdwg (setq thisdwg (vla-get-activedocument (vlax-get-acad-object))))
(foreach tsname all_tstyles
(if (not (vl-position tsname keep_tstyles))
(if (not (vl-catch-all-error-p (setq tstyle (vl-catch-all-apply 'vla-item (list (vla-get-textstyles thisdwg) tsname)))))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list tstyle)))))))
;;;Line Type Purge
(setq all_ltypes (mapcar (function (lambda (i) (strcase i)))(ai_table "ltype" 0)))
(setq keep_ltype (mapcar 'strcase (list "center" "hidden" "phantom" "phantom2" "dashed" "overhead_telco" "overhead_utility_supply" "bwirefence")))
(or thisdwg (setq thisdwg (vla-get-activedocument (vlax-get-acad-object))))
(foreach ltname all_ltypes
(if (not (vl-position ltname keep_ltype))
(if (not (vl-catch-all-error-p (setq ltype (vl-catch-all-apply 'vla-item (list (vla-get-linetypes thisdwg) ltname)))))
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list ltype)))))))
;;;Misc Purges
(command "-purge" "sh" "*" "N")
; (c:rui); a lisp to delete unattached images
; (c:lfd); a layer filter delete lisp
;(princ "\nDone purge")
(princ)
)