; Replace blocks by the same-named Xrefs
; (you may want to export the blocks to DWG files first)
; No attributes
;
; (C)2026 ARKANCE - www.cadforum.cz
;

(vl-load-com)

(defun c:B2X (/ ss i obj doc blocks name current-dwg-dir xref-path block-def xref-obj
                lay col rot sx sy sz ins-pt xref-def rename-idx old-name 
                unique-names name-map entry target-name target-path owner)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq blocks (vla-get-Blocks doc))
  (setq current-dwg-dir (getvar "DWGPREFIX"))
  
  (prompt "\nSelect block instances to convert to Xrefs: ")
  (if (not (setq ss (ssget '((0 . "INSERT")))))
    (progn (prompt "\nNo blocks selected.") (exit))
  )

  (vla-StartUndoMark doc)

  ;; 1. Pre-process and Build Name/Path Map
  ;; Map structure: (list (list RenamedInternalName OriginalName Path) ...)
  (setq name-map '() unique-names '() i 0)
  (repeat (sslength ss)
    (setq obj (vlax-ename->vla-object (ssname ss i)))
    (setq name (vla-get-EffectiveName obj))
    (if (not (member name unique-names))
      (progn
        (setq unique-names (cons name unique-names))
        
        ;; Resolve Xref Path BEFORE renaming
        (if (not (setq xref-path (findfile (strcat name ".dwg"))))
          (setq xref-path (findfile (strcat current-dwg-dir name ".dwg")))
        )
        
        (if xref-path
          (progn
            (prompt (strcat "\nFound matching DWG for \"" name "\": " xref-path))
            
            ;; Check if an internal block definition exists that conflicts
            (setq block-def (vl-catch-all-apply 'vla-item (list blocks name)))
            (if (and (not (vl-catch-all-error-p block-def))
                     (= (vla-get-IsXRef block-def) :vlax-false))
              (progn
                ;; RENAME INTERNAL BLOCK to clear the "name" for Xref
                (setq rename-idx 1)
                (setq old-name (strcat name "_INTERNAL_EXPIRED"))
                (while (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Name (list block-def (if (> rename-idx 1) (strcat old-name "_" (itoa rename-idx)) old-name))))
                  (setq rename-idx (1+ rename-idx))
                )
                (setq old-name (vla-get-Name block-def))
                (prompt (strcat "\nRenamed internal block to \"" old-name "\""))
                ;; Map the new name back to original intent
                (setq name-map (cons (list old-name name xref-path) name-map))
              )
              (progn
                ;; Already an Xref or clean - just map original to itself
                (setq name-map (cons (list name name xref-path) name-map))
              )
            )
          )
          (prompt (strcat "\nSkipping block \"" name "\": matching DWG not found."))
        )
      )
    )
    (setq i (1+ i))
  )

  ;; 2. Process Instances using Map
  (setq i 0)
  (repeat (sslength ss)
    (setq obj (vlax-ename->vla-object (ssname ss i)))
    (setq name (vla-get-EffectiveName obj)) ;; Might be "Dog_INTERNAL_EXPIRED" now
    
    ;; Look up original target name and path in map
    (setq entry (assoc name name-map))
    (if entry
      (progn
        (setq target-name (cadr entry)   ;; e.g. "Dog"
              target-path (caddr entry)) ;; e.g. "C:\Path\Dog.dwg"
              
        ;; Capture Properties
        (setq ins-pt (vla-get-InsertionPoint obj)
              lay    (vla-get-Layer obj)
              col    (vla-get-Color obj)
              rot    (vla-get-Rotation obj)
              sx     (vla-get-XScaleFactor obj)
              sy     (vla-get-YScaleFactor obj)
              sz     (vla-get-ZScaleFactor obj)
              owner  (vla-ObjectIDToObject doc (vla-get-OwnerID obj)))

        ;; Ensure the XREF "Dog" is defined
        (setq xref-def (vl-catch-all-apply 'vla-item (list blocks target-name)))
        (if (or (vl-catch-all-error-p xref-def)
                (= (vla-get-IsXRef xref-def) :vlax-false))
          ;; It doesn't exist yet as an Xref, so attach it
          (setq xref-obj (vla-AttachExternalReference owner target-path target-name ins-pt sx sy sz rot :vlax-false))
          ;; It's already correctly defined as an Xref, just insert instance
          (setq xref-obj (vla-InsertBlock owner ins-pt target-name sx sy sz rot))
        )

        ;; Final property polish
        (vla-put-Layer xref-obj lay)
        (vla-put-Color xref-obj col)
        
        ;; Delete the original instance
        (vla-Delete obj)
      )
    )
    (setq i (1+ i))
  )

  (vla-EndUndoMark doc)
  (princ "\nConversion complete. You may want to PURGE the old internal blocks.")
  (princ)
)

(princ "\nBlock-to-Xref loaded. Type B2X to start.")
(princ)