- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
spend some time learn lisp with chatgpt and we finally outcome a cleaning lisp for architect drawing,
and i am sharing here because i learn a lot from forum, and i also hope to get advice, upgrade and improvement for increase the work efficiency for this lisp.
(especially PHASE 5 – FAST DUPLICATE REMOVAL, _overkill all will stuck me for several hours to file collapse)
**Some key word replaced by "MAGIC WORD" due to privacy and confidential, so please reset them if you want to try it out.
;;; ============================================================
;;; HOUSEKEEPING.lsp
;;; ============================================================
;;; ============================================================
;;; PHASE 0 – Environment preparation
;;; ============================================================
(defun HK:P0-ENV ( / )
(princ "\n[Phase 0] Environment preparation...")
;; Safe system variables
(setvar "CMDECHO" 1)
(setvar "PICKFIRST" 1)
(setvar "EXPERT" 5)
;; Ensure Model Space
(if (= (getvar "TILEMODE") 0)
(command "._TILEMODE" 1)
)
;; Clear active command stack
(while (> (getvar "CMDACTIVE") 0) (command ""))
;; Force safe current layer
(setvar "CLAYER" "0")
(princ "\n[Phase 0] Environment locked, current layer set to 0.")
(princ)
)
;;; ============================================================
;;; PHASE 1 – View, UCS, Units
;;; ============================================================
(defun HK:P1-VIEW-UCS-UNITS ( / )
(princ "\n[Phase 1] Setting view, UCS, and units...")
(while (> (getvar "CMDACTIVE") 0) (command ""))
;; PLAN to World
(command "._PLAN" "_WORLD")
(while (> (getvar "CMDACTIVE") 0) (command ""))
;; UCS to World
(command "._UCS" "_WORLD")
;; Units (decimal, mm)
(setvar "LUNITS" 2)
(setvar "LUPREC" 8)
(setvar "AUNITS" 0)
(setvar "AUPREC" 8)
(setvar "INSUNITS" 4)
(princ "\n[Phase 1] View=World, UCS=World, Units=mm locked.")
(princ)
)
;;; ============================================================
;;; PHASE 2A – Layer reset & allow explode
;;; ============================================================
(defun HK:LAYER-RESET-ALL ( / )
(princ "\n[Phase 2A] Resetting layers (thaw/unlock/on)...")
(while (> (getvar "CMDACTIVE") 0) (command ""))
(command "._-LAYER" "_T" "*" "")
(command "._-LAYER" "_U" "*" "")
(command "._-LAYER" "_ON" "*" "")
(princ "\n[Phase 2A] All layers thawed, unlocked, and ON.")
(princ)
)
(defun HK:BLOCK-ALLOW-EXPLODE ( / doc blocks)
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq blocks (vla-get-Blocks doc))
(vlax-for blk blocks
(if (and (= (vla-get-IsLayout blk) :vlax-false)
(= (vla-get-IsXref blk) :vlax-false))
(vl-catch-all-apply 'vla-put-Explodable (list blk :vlax-true))
)
)
(princ "\nAll blocks set to allow exploding.")
(princ)
)
(defun HK:PROTECT-LAYERS (/ doc lays lay desc name)
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq lays (vla-get-Layers doc))
(princ "\n[Phase 2A] Protecting layers...")
(vlax-for lay lays
(setq name (vla-get-Name lay))
(setq desc (vla-get-Description lay))
(if (and desc
(wcmatch (strcase desc) "*MAGIC WORD*"))
(progn
(vla-put-Lock lay :vlax-true)
(vla-put-Freeze lay :vlax-true)
(vla-put-LayerOn lay :vlax-true)
(princ (strcat "\nProtected: " name))
)
)
)
(princ)
)
(defun HK:P2A-PREPARE (/)
(princ "\n[Phase 2A] Preparing layers and block permissions...")
(HK:LAYER-RESET-ALL)
;; Friendly fire protection
(HK:PROTECT-LAYERS)
(HK:BLOCK-ALLOW-EXPLODE)
(princ "\n[Phase 2A] Ready.")
(princ)
)
;;; ============================================================
;;; PHASE 2A – Lock 50% layers
;;; ============================================================
(defun HK:P2A-LOCK50 (/ lay layTable count totalLayers halfLayers)
(vl-load-com)
(setq layTable (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq count 0)
(setq totalLayers (vla-get-Count layTable))
(setq halfLayers (fix (/ totalLayers 2.0)))
(vlax-for lay layTable
(if (and (/= (vla-get-Name lay) "0")
(/= (vla-get-Name lay) (getvar "CLAYER"))
(< count halfLayers))
(progn
(vla-put-Lock lay :vlax-true)
(vla-put-Freeze lay :vlax-true)
(setq count (1+ count))
)
)
)
(princ (strcat "\n[P2A-LOCK50] " (itoa count) " layers locked."))
(princ)
)
;;; ============================================================
;;; PHASE 2B – Explode blocks automatically (safe with attributes)
;;; ============================================================
(defun HK:ATTR->TEXT (blkEnt / att data)
;; Convert block attributes to TEXT
(setq att (entnext blkEnt))
(while (and att (= (cdr (assoc 0 (entget att))) "ATTRIB"))
(setq data (entget att))
(entmake
(list
'(0 . "TEXT")
(cons 10 (cdr (assoc 10 data)))
(cons 40 (cdr (assoc 40 data)))
(cons 1 (cdr (assoc 1 data)))
(cons 7 (cdr (assoc 7 data)))
(cons 50 (cdr (assoc 50 data)))
(cons 8 (cdr (assoc 8 data)))
)
)
(setq att (entnext att))
)
)
(defun HK:EXPLODE-BLOCK-REF (ent / obj result)
(vl-load-com)
(if (and ent (entget ent))
(progn
(setq obj (vlax-ename->vla-object ent))
(setq result (vl-catch-all-apply 'vlax-invoke (list obj 'Explode)))
(if (not (vl-catch-all-error-p result))
(vla-delete obj)
)
)
)
)
(defun HK:P2B-BLOCK-EXPLODE (/ ss i ent)
(vl-load-com)
(princ "\n[P2B] Controlled explode...")
;; ONLY ATTR->TEXT ONCE
(setq ss (ssget "_X" '((0 . "INSERT"))))
(if ss
(progn
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(HK:ATTR->TEXT ent)
(setq i (1+ i))
)
)
)
;; MULTIPLE explode
(repeat 5
(setq ss (ssget "_X" '((0 . "INSERT"))))
(if ss
(progn
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(HK:EXPLODE-BLOCK-REF ent)
(setq i (1+ i))
)
)
)
)
(princ "\n[P2B] Done.")
)
;;; ============================================================
;;; PHASE 2C – Unlock all layers
;;; ============================================================
(defun HK:P2C-LAYER-RESET (/)
(princ "\n[P2C] Resetting layers...")
(command "._-LAYER" "_T" "*" "")
(command "._-LAYER" "_U" "*" "")
(command "._-LAYER" "_ON" "*" "")
;; Friendly fire protection again
(HK:PROTECT-LAYERS)
(princ "\n[P2C] Layers reset and INF layers protected.")
(princ)
)
;;; ============================================================
;;; PHASE 2D – AUDIT
;;; ============================================================
(defun HK:P2D-AUDIT (/)
(vl-cmdf "_AUDIT" "_Y")
(princ "\n[P2D] AUDIT complete, errors fixed.")
(princ)
)
;;; ============================================================
;;; PHASE 3 – Pre-clean (safe)
;;; ============================================================
(defun HK:ERASE-BY-TYPE (type / ss)
(setq ss (ssget "_X" (list (cons 0 type))))
(if ss (command "_.ERASE" ss ""))
)
(defun HK:ERASE-SOLID-HATCH (/ ss i ent)
(setq ss (ssget "_X" '((0 . "HATCH"))))
(if ss
(progn
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(HK:SAFE-MTEXT-CLEAN ent)
(setq i (1+ i))
)
)
)
)
(defun HK:ERASE-EMPTY-BLOCKS (/ ss i en ed blk)
(setq ss (ssget "_X" '((0 . "INSERT"))))
(if ss
(progn
(setq i 0)
(while (< i (sslength ss))
(setq en (ssname ss i)
ed (entget en)
blk (tblsearch "BLOCK" (cdr (assoc 2 ed))))
(if (and blk
(= 0 (logand 1 (cdr (assoc 70 blk))))
(null (cdr (assoc -2 blk)))
)
(command "_.ERASE" en "")
)
(setq i (1+ i))
)
)
)
)
(defun HK:SAFE-MTEXT-CLEAN (ent / data txt)
(if (and ent (setq data (entget ent)))
(progn
(setq txt (cdr (assoc 1 data)))
(if txt
(progn
;; Strip color codes
(setq txt (StripMTextColor txt))
;; Update entity with cleaned text
(entmod (subst (cons 1 txt) (assoc 1 data) data))
)
)
;; Delete if text is empty
(if (or (null txt) (= txt ""))
(entdel ent)
)
)
)
)
(defun HK:CLEAN-REGAPP ( / )
(princ "\nCleaning RegApp records...")
(command "._-PURGE" "_R" "*" "_N")
(princ "\nRegApp cleanup completed.")
)
(defun HK:P3-ERASE (/ ss i ent)
(princ "\n[Phase 3] Pre-clean started...")
;; Safe MTEXT cleanup
(setq ss (ssget "_X" '((0 . "MTEXT"))))
;; Other junk
(HK:ERASE-BY-TYPE "WIPEOUT")
(HK:ERASE-BY-TYPE "POINT")
(HK:ERASE-BY-TYPE "OLE2FRAME")
(HK:ERASE-BY-TYPE "REGION")
(HK:ERASE-BY-TYPE "ATTDEF")
(HK:ERASE-SOLID-HATCH)
(HK:ERASE-EMPTY-BLOCKS)
;; REGAPP purge
(HK:CLEAN-REGAPP)
(princ "\n[Phase 3] Pre-clean completed.")
(princ)
)
;;; ============================================================
;;; PHASE 4 – Flatten + Elevation Reset
;;; ============================================================
(defun HK:P4-ZMOVE (/ ss)
(princ "\n[Phase 4] Flattening and Elevation Reset...")
(setq ss (ssget "_X"))
(if ss
(repeat 2
(command "._CHANGE" ss "" "_Properties" "_Elevation" "0" "")
)
)
(command "_FLATTEN" "_ALL" "")
(command "_AUDIT" "_Y" "_REGEN")
(princ "\n[Phase 4] Elevation reset, flatten, audit done.")
(princ)
)
;;; ============================================================
;;; PHASE 5 – FAST DUPLICATE REMOVAL
;;; Supports LINE, ARC, CIRCLE, LWPOLYLINE
;;; ============================================================
(defun HK:SAFE-NUM (v) (if (numberp v) v 0.0))
(defun HK:SAFE-PT (p) (if (and p (= (length p) 3)) p '(0 0 0)))
(defun HK:ROUND (val prec) (if (numberp val) (/ (float (fix (* val prec))) prec) 0.0))
(defun HK:PT-KEY (pt prec)
(if (and pt (= (length pt) 3))
(strcat (rtos (HK:ROUND (car pt) prec) 2 6) ","
(rtos (HK:ROUND (cadr pt) prec) 2 6) ","
(rtos (HK:ROUND (caddr pt) prec) 2 6))
"0,0,0")
)
(defun HK:LINE-KEY (edata prec / p1 p2 tmp)
(setq p1 (HK:SAFE-PT (cdr (assoc 10 edata))))
(setq p2 (HK:SAFE-PT (cdr (assoc 11 edata))))
(if (> (car p1) (car p2))
(setq tmp p1 p1 p2 p2 tmp))
(strcat "LINE|" (HK:PT-KEY p1 prec) "|" (HK:PT-KEY p2 prec))
)
(defun HK:ARC-KEY (edata prec / c r sa ea)
(setq c (HK:SAFE-PT (cdr (assoc 10 edata))))
(setq r (HK:SAFE-NUM (cdr (assoc 40 edata))))
(setq sa (HK:SAFE-NUM (cdr (assoc 50 edata))))
(setq ea (HK:SAFE-NUM (cdr (assoc 51 edata))))
(strcat "ARC|" (HK:PT-KEY c prec) "|"
(rtos (HK:ROUND r prec) 2 6) "|"
(rtos (HK:ROUND sa prec) 2 6) "|"
(rtos (HK:ROUND ea prec) 2 6))
)
(defun HK:CIRCLE-KEY (edata prec / c r)
(setq c (HK:SAFE-PT (cdr (assoc 10 edata))))
(setq r (HK:SAFE-NUM (cdr (assoc 40 edata))))
(strcat "CIRCLE|" (HK:PT-KEY c prec) "|" (rtos (HK:ROUND r prec) 2 6))
)
(defun HK:PLINE-KEY (edata prec / verts key)
(setq verts
(mapcar
'(lambda (x) (HK:PT-KEY (HK:SAFE-PT (cdr x)) prec))
(vl-remove-if-not '(lambda (a) (= (car a) 10)) edata)))
(setq key (apply 'strcat (mapcar '(lambda (v) (strcat v "|")) verts)))
(strcat "PLINE|" key)
)
(defun HK:BUILD-KEY (ent prec / ed typ)
(setq ed (entget ent))
(setq typ (cdr (assoc 0 ed)))
(cond
((= typ "LINE") (HK:LINE-KEY ed prec))
((= typ "ARC") (HK:ARC-KEY ed prec))
((= typ "CIRCLE") (HK:CIRCLE-KEY ed prec))
((= typ "LWPOLYLINE") (HK:PLINE-KEY ed prec))
(T nil)
)
)
(defun HK:COLLECT-GEOM ( / ss i ent key lst)
(setq lst '())
(setq ss (ssget "_X"
'((-4 . "<OR")
(0 . "LINE")
(0 . "ARC")
(0 . "CIRCLE")
(0 . "LWPOLYLINE")
(-4 . "OR>"))))
(if ss
(progn
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq key (HK:BUILD-KEY ent 0.01))
(if key
(setq lst (cons (list key ent) lst))
)
(setq i (1+ i))
)
)
)
lst
)
(defun HK:REMOVE-DUPLICATES (lst / sorted prev removed)
(setq removed 0)
(setq sorted
(vl-sort lst
'(lambda (a b)
(< (car a) (car b))
)
)
)
(setq prev nil)
(foreach item sorted
(if (and prev (equal (car item) (car prev)))
(if (and (cadr item) (entget (cadr item)))
(progn
(entdel (cadr item))
(setq removed (1+ removed))
)
)
)
(setq prev item)
)
removed
)
(defun HK:P5-FAST-CLEAN ( / data removed)
(princ "\n[Phase 5] Fast duplicate removal (LINE/ARC/CIRCLE/LWPOLYLINE)...")
(setq data (HK:COLLECT-GEOM))
(if data
(progn
(setq removed (HK:REMOVE-DUPLICATES data))
(princ (strcat "\nRemoved duplicates: " (itoa removed)))
)
)
;; Purge & Audit
(command "-purge" "All" "*" "N")
(command "_AUDIT" "_Y")
(princ "\n[Phase 5] Completed.")
)
;;; =========================
;;; PHASE 6 RESET LAYER
;;; =========================
(setq *p6-core-layers*
'(
("_Grid" "Grid" 8 "Center")
("_Archi" "Architect" 8 "Continuous")
("MAGIC WORD")
("MAGIC WORD")
)
)
(setq *p6-layermrg-rules*
'(
("_ARCHI" ("building" "bldg" "elev" "site" "factory" "area"
"door" "window" "wall" "column" "roof"
"floor" "slab" "ramp" "drain"
"sanitary" "toilet" "office" "room"
"highway" "jalan" "road" "park" "parking"
))
("_Grid" ("grid"))
("_Mech" ("machine" "production" "worker"
"table" "sofa" "furniture" ))
("MAGIC WORD" ("MAGIC WORD" "MAGIC WORD" ))
("MAGIC WORD" ("MAGIC WORD" "MAGIC WORD"))
)
)
;;; ------------------------------------------------------------
;;; Create layer if not exists
;;; ------------------------------------------------------------
(defun p6:create-layer (def / doc lays lay)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq lays (vla-get-Layers doc))
(if (not (tblsearch "LAYER" (car def)))
(progn
(setq lay (vla-add lays (car def)))
(vla-put-Description lay (cadr def))
(vla-put-Color lay (nth 2 def))
(if (not (tblsearch "LTYPE" (nth 3 def)))
(command "-linetype" "load" (nth 3 def) "acad.lin" "")
)
(vla-put-Linetype lay (nth 3 def))
)
)
)
;;; ------------------------------------------------------------
;;; Layer name match (case-insensitive)
;;; ------------------------------------------------------------
(defun p6:layer-match (lname key)
(if (and lname key)
(wcmatch (strcase lname) (strcat "*" (strcase key) "*"))
nil
)
)
;;; ------------------------------------------------------------
;;; Remove duplicates from list
;;; ------------------------------------------------------------
(defun p6:list-unique (lst / r)
(setq r '())
(foreach x lst
(if (not (member x r))
(setq r (cons x r))
)
)
(reverse r)
)
;;; ------------------------------------------------------------
;;; SAFE merge layers
;;; ------------------------------------------------------------
(defun p6:run-merge-safe (/ doc layers rule target keys hits h layFlag)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
;; collect layer names
(setq layers '())
(vlax-for x (vla-get-Layers doc)
(setq layers (cons (vla-get-Name x) layers))
)
;; process rules
(foreach rule *p6-layermrg-rules*
(setq target (car rule))
(setq keys (cadr rule))
(setq hits '())
;; find matching layers
(foreach h layers
(if (and (/= h "0") (/= h "DEFPOINTS") (not (wcmatch h "*|*"))
(not (wcmatch (strcase h) "*INFINITE*"))) ;; skip INF layers
(foreach k keys
(if (and (p6:layer-match h k) (/= h target))
(progn
;; CHECK LOCK AND FREEZE
(setq layFlag (cdr (assoc 70 (tblsearch "LAYER" h))))
(setq layFlag (if (numberp layFlag) layFlag 0))
(if (= 0 (logand layFlag 20)) ;; ONLY UNLOCK & THAW
(setq hits (cons h hits))
)
)
)
)
)
)
;; remove duplicates
(setq hits (p6:list-unique hits))
(setq hits (vl-remove-if '(lambda (l) (not (tblsearch "LAYER" l))) hits))
(if hits
(progn
(foreach h hits
(if (/= (strcase h) (strcase target))
(progn
;; ONLY merge thaw/unlock/on LAYER
(command "-LAYMRG" "N" h "" "N" target "Y")
)
)
)
)
(princ (strcat "\n[P6] No layers to merge into " target))
)
)
)
;;; ------------------------------------------------------------
;;; Set all objects BYLAYER
;;; ------------------------------------------------------------
(defun p6:set-bylayer ()
(setq ss (ssget "_X"))
(if ss
(command "_.CHPROP" ss "" "_COLOR" "BYLAYER" "")
)
)
;;; ------------------------------------------------------------
;;; Main Phase 6 Entry
;;; ------------------------------------------------------------
(defun HK:P6-RELAYER ( / ss ent i)
(princ "\n[Phase 6] Layer normalization started...")
;; create core layers
(foreach x *p6-core-layers*
(p6:create-layer x)
)
;; merge layers safely
(p6:run-merge-safe)
;; set all objects BYLAYER
(p6:set-bylayer)
;; --- change all hatch color to 9 ---
(setq ss (ssget "_X" '((0 . "HATCH"))))
(if ss
(command "_.CHPROP" ss "" "_COLOR" "9" "")
)
(princ "\n[Phase 6] Completed.")
)
;;; =========================
;;; HK-PHASE 7
;;; =========================
(defun HK:LOCK-PRODUCTION-LAYERS ( / lay)
(foreach lay
'("_Grid" "_Archi" "MAGIC WORD" "MAGIC WORD" )
(if (tblsearch "LAYER" lay)
(command "-LAYER" "LOCK" lay "")
)
)
)
(defun HK:GREY-UNLOCKED-LAYERS (/ lay name flag)
(setq lay (tblnext "LAYER" T))
(while lay
(setq name (cdr (assoc 2 lay)))
(setq flag (if (numberp (cdr (assoc 70 lay)))
(cdr (assoc 70 lay))
0))
;; bit 4 = locked
(if (= 0 (logand flag 4))
(command "-LAYER" "COLOR" "8" name "")
)
(setq lay (tblnext "LAYER"))
)
)
(defun HK:LOCK-ALL-LAYERS ()
(command "-LAYER" "LOCK" "*" "")
)
;;; =========================
;;; OVERKILL
;;; =========================
(defun HK:OVERKILL-ALL ( / ss)
(princ "\n[OVERKILL] Running on entire drawing...")
(vl-load-com)
;; SELECT ALL
(setq ss (ssget "_X"))
(if ss
(progn
;; START OVERKILL
(command "._OVERKILL" ss "")
;; END
(command "")
(princ "\n[OVERKILL] Completed.")
)
(princ "\n[OVERKILL] Nothing selected.")
)
(princ)
)
;;; =========================
;;; PHASE 7 READY
;;; =========================
(defun HK:P7-READY ( / )
(princ "\n[Phase 7] Finalizing drawing...")
;; purge
(command "-PURGE" "ALL" "*" "N")
;; lock production layers
(HK:LOCK-PRODUCTION-LAYERS)
;; Friendly fire protection
(HK:PROTECT-LAYERS)
;; grey remaining layers
(HK:GREY-UNLOCKED-LAYERS)
;; CALL OVERKILL
(HK:OVERKILL-ALL)
;; audit
(command "_AUDIT" "_Y")
;; regen
(command "_REGENALL")
;; lock all layers
(command "-LAYER" "LOCK" "*" "")
(command "-LAYER" "_T" "*" "")
(command "-LAYER" "_ON" "*" "")
(princ "\n[Phase 7] Completed.")
)
;;; ============================================================
;;; ENTRY POINT
;;; ============================================================
(defun c:HOUSEKEEPING ( / )
(princ "\n[HOUSEKEEPING] Start...")
(HK:P0-ENV)
(HK:P1-VIEW-UCS-UNITS)
(HK:P2A-PREPARE)
(HK:P2B-BLOCK-EXPLODE)
(HK:P2C-LAYER-RESET)
(HK:P2B-BLOCK-EXPLODE)
(HK:P2D-AUDIT)
(HK:P3-ERASE)
(HK:P4-ZMOVE)
(HK:P5-FAST-CLEAN)
(HK:P6-RELAYER)
(HK:P7-READY)
(princ "\n[HOUSEKEEPING] Done.")
(setq defaultFolder (getvar "DWGPREFIX")) ; CURRENT DOCUMENT
(setq savePath (getfiled "Save Housekeeping As" defaultFolder "dwg" 1))
(if savePath
(command "_SAVEAS" "2010" savePath)
)
(princ)
)
Solved! Go to Solution.
