;;; ========================================================================== ;;; XREF-CLEANUP.LSP v4.6 - Flujo Interactivo con Seleccion Visual ;;; ========================================================================== ;;; Flujo: ;;; 1. Seleccionar Xref / independizar si multi-instancia ;;; 2. Registrar capas Xref y bloques pre-bind ;;; 3. BIND nativo (_-xref) o ActiveX con BINDTYPE = 0 ;;; 4. Detectar modo post-bind: PREFIX o MERGE con wcmatch ;;; 5. ON + THAW todas las capas Xref / Explotar bloque ;;; 6. Rastrear entidades nuevas con entnext ;;; 7. BLOQUEAR solo capas Xref ;;; 8. Seleccion interactiva nativa (Loop clics + visual REGEN + ERRNO 52/7) ;;; 9. Eliminar entidades Xref en capas bloqueadas ;;; 10. Restaurar locks originales del dibujo ;;; 11. Renombrar/fusionar capas conservadas (modo PREFIX, last-pos search) ;;; 12. Eliminar capas descartadas por completo con todo su contenido (-LAYDEL siempre!) ;;; 13. Eliminar capas vacias / purgar bloques huerfanos ;;; ========================================================================== (vl-load-com) ;;; --- UTILIDADES ----------------------------------------------------------- (defun xref-cleanup:normalize (str / i len out c v) "Mayusculas, sin espacios/guiones bajos, tildes->base" (setq str (strcase str) len (strlen str) out "" i 1) (while (<= i len) (setq c (substr str i 1) v (ascii c)) (cond ((member v '(32 95)) (setq c "")) ((member v '(65 97 193 225)) (setq c "A")) ((member v '(69 101 201 233)) (setq c "E")) ((member v '(73 105 205 237)) (setq c "I")) ((member v '(79 111 211 243)) (setq c "O")) ((member v '(85 117 218 250 220 252)) (setq c "U")) ((member v '(78 110 209 241)) (setq c "N")) ) (setq out (strcat out c) i (1+ i)) ) out ) (defun xref-cleanup:member-ci (str lst) "member case-insensitive" (if (and str lst) (progn (setq str (strcase str)) (vl-some '(lambda (x) (= (strcase x) str)) lst)))) ;;; --- COMANDO PRINCIPAL ---------------------------------------------------- (defun C:XREF-CLEANUP ( / *error* old-ce old-ex old-cl old-bt old-nm last-pos doc blocks cSpace sel ent data xrefName xrefPath blockData blockFlags isXref ssInst numInst tempName suffix insPt scX scY scZ rot norm newXO newIO newEnt blockObj xrefLayFull xrefLayShort preBindBlk lastEntBefore layRec lN sN layObj oldLO newLO newLN xrefPostLay bindMode bindResult xrefEnts xrefEntLays totalXE e eD eL savedLocks hasLocked keptLays discLays delCnt keepCnt delR blk bN postBindBlk result) ;; - ERROR HANDLER - (defun *error* (msg) (if (not (member msg '("Function cancelled" "quit / exit abort" "Command cancelled" "cancelar" "Función cancelada"))) (princ (strcat "\n\n[ERROR] " msg))) (while (> (getvar "CMDACTIVE") 0) (command "")) (if savedLocks (foreach p savedLocks (if (tblobjname "layer" (car p)) (vl-catch-all-apply 'vla-put-Lock (list (vlax-ename->vla-object (tblobjname "layer" (car p))) (if (cdr p) :vlax-true :vlax-false)))))) (if old-ce (setvar "CMDECHO" old-ce)) (if old-ex (setvar "EXPERT" old-ex)) (if old-cl (setvar "CLAYER" old-cl)) (if old-bt (setvar "BINDTYPE" old-bt)) (if old-nm (setvar "NOMUTT" old-nm)) (if doc (vla-EndUndoMark doc)) (princ "\n[XGEOMETRIA] Cancelado. Deshacer con UNDO.") (princ)) ;; - SETUP - (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (vla-StartUndoMark doc) (setq old-ce (getvar "CMDECHO") old-ex (getvar "EXPERT") old-cl (getvar "CLAYER") old-nm (getvar "NOMUTT")) (setvar "CMDECHO" 0) (setvar "EXPERT" 5) (setvar "NOMUTT" 1) (setq savedLocks nil) (princ "\n======================================================================") (princ "\n[XGEOMETRIA] v4.6 - Seleccion Visual Interactiva") (princ "\n======================================================================") ;; - SELECCION - (princ "\n\nSelecciona la Xref...") (setvar "NOMUTT" 0) (setq sel (entsel)) (setvar "NOMUTT" 1) (if (not sel) (princ "\nCancelado.") (progn (setq ent (car sel) data (entget ent) xrefName (cdr (assoc 2 data)) blockData (if xrefName (tblsearch "block" xrefName)) blockFlags (if blockData (cdr (assoc 70 blockData)) 0) isXref (and blockFlags (= (logand blockFlags 4) 4)) xrefPath (if (and isXref blockData (cdr (assoc 1 blockData))) (findfile (cdr (assoc 1 blockData))))) (cond ((/= (cdr (assoc 0 data)) "INSERT") (princ "\n[ERROR] No es un INSERT.")) ((not blockData) (princ (strcat "\n[ERROR] Bloque \"" xrefName "\" no encontrado."))) ((not isXref) (princ (strcat "\n[ERROR] \"" xrefName "\" no es una Xref."))) ((not xrefPath) (princ "\n[ERROR] Archivo de la Xref no encontrado.")) ;; ============================================================ ;; XREF VALIDA - PROCESO PRINCIPAL ;; ============================================================ (T (princ) (setq blocks (vla-get-Blocks doc) cSpace (vla-get-Block (vla-get-ActiveLayout doc)) tempName xrefName) ;; - FASE 1: MULTI-INSTANCIA - (setq ssInst (ssget "_X" (list (cons 0 "INSERT") (cons 2 xrefName))) numInst (if ssInst (sslength ssInst) 0)) (if (> numInst 1) (progn (setq suffix 1 tempName (strcat xrefName "_CLEAN_" (itoa suffix))) (while (tblsearch "block" tempName) (setq suffix (1+ suffix) tempName (strcat xrefName "_CLEAN_" (itoa suffix)))) (setq insPt (cdr (assoc 10 data)) scX (cdr (assoc 41 data)) scY (cdr (assoc 42 data)) scZ (cdr (assoc 43 data)) rot (cdr (assoc 50 data)) norm (cdr (assoc 210 data))) ;; Crear Xref temporal (setq newXO (vla-AttachExternalReference cSpace xrefPath tempName (vlax-3d-point '(0.0 0.0 0.0)) 1.0 1.0 1.0 0.0 :vlax-false)) (vla-delete newXO) ;; Sincronizar estados de capas (setq layRec (tblnext "layer" T)) (while layRec (setq lN (cdr (assoc 2 layRec))) (if (wcmatch (strcase lN) (strcat (strcase xrefName) "|*")) (progn (setq last-pos (vl-string-position (ascii "|") lN nil T)) (setq sN (substr lN (+ last-pos 2))) (setq newLN (strcat tempName "|" sN)) (if (and (tblsearch "layer" lN) (tblsearch "layer" newLN)) (progn (setq oldLO (vlax-ename->vla-object (tblobjname "layer" lN)) newLO (vlax-ename->vla-object (tblobjname "layer" newLN))) (vla-put-LayerOn newLO (vla-get-LayerOn oldLO)) (vl-catch-all-apply 'vla-put-Freeze (list newLO (vla-get-Freeze oldLO))))))) (setq layRec (tblnext "layer"))) ;; Reemplazar instancia (setq newIO (vla-InsertBlock cSpace (vlax-3d-point insPt) tempName scX scY scZ rot)) (if norm (vla-put-Normal newIO (vlax-3d-point norm))) (setq newEnt (vlax-vla-object->ename newIO)) (entdel ent) (setq ent newEnt)) (princ)) ;; - FASE 2: REGISTRO PRE-BIND - (setq xrefLayFull nil xrefLayShort nil layRec (tblnext "layer" T)) (while layRec (setq lN (cdr (assoc 2 layRec))) (if (wcmatch (strcase lN) (strcat (strcase tempName) "|*")) (progn (setq last-pos (vl-string-position (ascii "|") lN nil T)) (setq sN (substr lN (+ last-pos 2))) (setq xrefLayFull (cons lN xrefLayFull) xrefLayShort (cons sN xrefLayShort)))) (setq layRec (tblnext "layer"))) ;; Bloques pre-bind (setq preBindBlk nil) (vlax-for blk blocks (setq preBindBlk (cons (vla-get-Name blk) preBindBlk))) ;; - FASE 3: BIND - (setq old-bt (getvar "BINDTYPE")) (setvar "BINDTYPE" 0) (setq bindResult (vl-catch-all-apply 'vl-cmdf (list "_.-xref" "_b" tempName))) (if (or (null bindResult) (vl-catch-all-error-p bindResult)) (vl-catch-all-apply '(lambda () (setq blockObj (vla-Item blocks tempName)) (vla-Bind blockObj :vlax-true)) nil)) (setvar "BINDTYPE" old-bt) (setvar "CLAYER" "0") ;; - FASE 4: DETECCION POST-BIND - (setq xrefPostLay nil bindMode nil) ;; Buscar capas con $ usando wcmatch (setq layRec (tblnext "layer" T)) (while layRec (setq lN (cdr (assoc 2 layRec))) (if (wcmatch (strcase lN) (strcat (strcase tempName) "$*")) (progn (setq xrefPostLay (cons lN xrefPostLay)) (if (not bindMode) (setq bindMode "PREFIX")))) (setq layRec (tblnext "layer"))) ;; Si no hay $, modo fusion (if (not bindMode) (progn (setq bindMode "MERGE") (foreach sN xrefLayShort (if (tblsearch "layer" sN) (setq xrefPostLay (cons sN xrefPostLay))))) (princ)) ;; - FASE 5: VISIBILIDAD + EXPLODE - (foreach lN xrefPostLay (if (tblobjname "layer" lN) (progn (setq layObj (vlax-ename->vla-object (tblobjname "layer" lN))) (vla-put-LayerOn layObj :vlax-true) (vl-catch-all-apply 'vla-put-Freeze (list layObj :vlax-false))))) ;; Frontera de entidades (setq lastEntBefore (entlast)) (command "_.explode" ent) ;; - FASE 6: RASTREO DE ENTIDADES - (setq xrefEnts nil xrefEntLays nil) (setq e (entnext lastEntBefore)) (while e (setq eD (vl-catch-all-apply 'entget (list e))) (if (and (not (vl-catch-all-error-p eD)) eD (assoc 8 eD)) (progn (setq eL (cdr (assoc 8 eD))) (setq xrefEnts (cons (cons e eL) xrefEnts)) (if (not (xref-cleanup:member-ci eL xrefEntLays)) (setq xrefEntLays (cons eL xrefEntLays))))) (setq e (entnext e))) (setq totalXE (length xrefEnts)) ;; - FASE 7: BLOQUEAR CAPAS XREF - (setq savedLocks nil) (foreach eL xrefEntLays (if (tblobjname "layer" eL) (progn (setq layObj (vlax-ename->vla-object (tblobjname "layer" eL))) (setq savedLocks (cons (cons eL (= (vla-get-Lock layObj) :vlax-true)) savedLocks)) (vla-put-Lock layObj :vlax-true)))) ;; Verificar que hay capas bloqueadas (setq hasLocked nil) (foreach p savedLocks (if (and (tblobjname "layer" (car p)) (= (vla-get-Lock (vlax-ename->vla-object (tblobjname "layer" (car p)))) :vlax-true)) (setq hasLocked T))) (command "_.regen") ;; - FASE 8: SELECCION INTERACTIVA - (princ "\n") (princ "\n======================================================================") (princ "\n SELECCION INTERACTIVA") (princ "\n Las capas de la Xref estan BLOQUEADAS (atenuadas).") (princ "\n Haga clic en objetos de las capas que desea CONSERVAR.") (princ "\n Puede hacer clic en multiples objetos uno por uno.") (princ "\n Presione ENTER o clic derecho en el vacio cuando termine.") (princ "\n======================================================================\n") (setq keptLays nil discLays nil) (if hasLocked (progn (setq continueSel T) (setvar "NOMUTT" 0) (while continueSel (setvar "ERRNO" 0) (setq selObj (vl-catch-all-apply 'entsel (list "\nSeleccione objeto de la capa a conservar (o ENTER para terminar): "))) (cond ((vl-catch-all-error-p selObj) (setq continueSel nil)) ((not selObj) (setq errVal (getvar "ERRNO")) (cond ((= errVal 52) (setq continueSel nil) (princ)) ((= errVal 7) (princ) (princ)) (T (setq continueSel nil)))) (T (setq entName (car selObj) entData (entget entName) entLay (cdr (assoc 8 entData))) (if (xref-cleanup:member-ci entLay xrefEntLays) (progn (if (not (xref-cleanup:member-ci entLay keptLays)) (progn (setq keptLays (cons entLay keptLays)) (setq layObj (vlax-ename->vla-object (tblobjname "layer" entLay))) (vla-put-Lock layObj :vlax-false) (command "_.regen") (princ (strcat "\n[OK] Capa \"" entLay "\" DESBLOQUEADA y agregada a conservadas."))) (princ))) (princ))))) (setvar "NOMUTT" 1) (foreach p savedLocks (setq lN (car p)) (if (not (xref-cleanup:member-ci lN keptLays)) (setq discLays (cons lN discLays))))) (princ)) ;; - FASE 10: ELIMINACION - (setq delCnt 0 keepCnt 0) (foreach p xrefEnts (setq e (car p) eL (cdr p)) (if (xref-cleanup:member-ci eL discLays) (progn (setq delR (vl-catch-all-apply 'entdel (list e))) (if (not (vl-catch-all-error-p delR)) (setq delCnt (1+ delCnt)))) (setq keepCnt (1+ keepCnt)))) ;; - FASE 11: RESTAURAR LOCK - (foreach p savedLocks (setq lN (car p)) (if (tblobjname "layer" lN) (cond ;; Capa conservada: restaurar estado original ((xref-cleanup:member-ci lN keptLays) (if (cdr p) ;; estaba locked originalmente (progn (setq layObj (vlax-ename->vla-object (tblobjname "layer" lN))) (vla-put-Lock layObj :vlax-true)))) ;; Capa descartada en MERGE: restaurar estado original ((and (xref-cleanup:member-ci lN discLays) (= bindMode "MERGE")) (progn (setq layObj (vlax-ename->vla-object (tblobjname "layer" lN))) (vla-put-Lock layObj (if (cdr p) :vlax-true :vlax-false)))) ;; Capa descartada en PREFIX: desbloquear para poder eliminar ((and (xref-cleanup:member-ci lN discLays) (= bindMode "PREFIX")) (progn (setq layObj (vlax-ename->vla-object (tblobjname "layer" lN))) (vla-put-Lock layObj :vlax-false)))))) (setq savedLocks nil) ;; limpiar para que *error* no restaure ;; - FASE 12: RENOMBRAR / FUSIONAR - (if (= bindMode "PREFIX") (progn (foreach lN keptLays (setq last-pos (vl-string-position (ascii "$") lN nil T)) (if last-pos (progn (setq sN (substr lN (+ last-pos 2))) (if (tblsearch "layer" sN) (command "_.-laymrg" "_n" lN "" "_n" sN "_y") (if (tblobjname "layer" lN) (progn (setq layObj (vlax-ename->vla-object (tblobjname "layer" lN))) (setq result (vl-catch-all-apply 'vla-put-Name (list layObj sN))) (if (vl-catch-all-error-p result) (princ (strcat "\n[ERROR] Al renombrar \"" lN "\": " (vl-catch-all-error-message result)))))))))))) ;; - FASE 13: ELIMINAR CAPAS DESCARTADAS - (foreach lN discLays (if (tblobjname "layer" lN) (progn (setq layObj (vlax-ename->vla-object (tblobjname "layer" lN))) (vla-put-Lock layObj :vlax-false) (vla-put-LayerOn layObj :vlax-true) (vl-catch-all-apply 'vla-put-Freeze (list layObj :vlax-false)) (command "_.-laydel" "_n" lN "" "_y")))) ;; - FASE 14: CAPAS HUERFANAS - (setq layRec (tblnext "layer" T)) (while layRec (setq lN (cdr (assoc 2 layRec))) (if (wcmatch (strcase lN) (strcat (strcase tempName) "|*")) (progn (if (tblobjname "layer" lN) (progn (setq layObj (vlax-ename->vla-object (tblobjname "layer" lN))) (vla-put-Lock layObj :vlax-false) (vla-put-LayerOn layObj :vlax-true) (vl-catch-all-apply 'vla-put-Freeze (list layObj :vlax-false)) (command "_.-laydel" "_n" lN "" "_y"))))) (setq layRec (tblnext "layer"))) ;; - FASE 15: PURGA BLOQUES - (setq postBindBlk nil) (vlax-for blk blocks (setq bN (vla-get-Name blk)) (if (not (member bN preBindBlk)) (setq postBindBlk (cons bN postBindBlk)))) (repeat 3 (command "_.-purge" "_b" "*" "_n") (command "_.-purge" "_all" "*" "_n")) (if (> numInst 1) (vl-catch-all-apply 'vl-cmdf (list "_.-purge" "_b" tempName "_n"))) ;; - RESUMEN - ;; El usuario prefiere no imprimir esta informacion en pantalla. ;; Se deja en comentarios para referencia y mantenimiento. ;; (princ "\n\n======================================================================") ;; (princ "\n[XGEOMETRIA] Completado!") ;; (princ (strcat "\n Modo bind: " bindMode)) ;; (princ (strcat "\n Entidades Xref: " (itoa totalXE))) ;; (princ (strcat "\n Eliminadas: " (itoa delCnt))) ;; (princ (strcat "\n Conservadas: " (itoa keepCnt))) ;; (princ (strcat "\n Capas conservadas (" (itoa (length keptLays)) "):")) ;; (foreach lN keptLays (princ (strcat "\n + \"" lN "\""))) ;; (princ (strcat "\n Capas eliminadas (" (itoa (length discLays)) "):")) ;; (foreach lN discLays (princ (strcat "\n - \"" lN "\""))) ;; (princ (strcat "\n Bloques nuevos: " (itoa (length postBindBlk)))) ;; (princ "\n======================================================================") (princ "\n[XGEOMETRIA] Completado!") ) ;; end T ) ;; end cond ) ;; end progn sel ) ;; end if sel ;; - RESTAURAR - (if old-ce (setvar "CMDECHO" old-ce)) (if old-ex (setvar "EXPERT" old-ex)) (if old-cl (setvar "CLAYER" old-cl)) (if old-nm (setvar "NOMUTT" old-nm)) (vla-EndUndoMark doc) (princ)) ;;; --- ALIAS ---------------------------------------------------------------- (defun C:XGEOMETRIA () (C:XREF-CLEANUP)) (princ "\n[XGEOMETRIA] v4.6 cargado. Escribe XGEOMETRIA para iniciar.") (princ)