;;; ============================================================
;;;  XRBIND.lsp  —  Внешние ссылки AutoCAD: внедрение / ремонт
;;;  AutoCAD 2025/2026.  Dionis / Олег.
;;;  Команды:
;;;    XRBIND    — внедрить ВСЕ РАЗРЕШЁННЫЕ ссылки в активном чертеже
;;;    XRBIND1   — внедрить одну ссылку (спросит имя)
;;;    XRLIST    — список ссылок со статусом, без изменений чертежа
;;;    XRPATH    — сменить путь битой ссылки (указать, где лежит файл)
;;;    XRUNBIND  — ОТСОЕДИНИТЬ только неразрешённые (битые) ссылки
;;;    XRDETACH  — отсоединить ВСЕ ссылки (с подтверждением)
;;;  Отчёт: %TEMP%\xrbind_report.txt
;;; ============================================================

(setq *xrb-log* (strcat (getenv "TEMP") "\\xrbind_report.txt"))

;; ---- список имён внешних ссылок (порядок как в чертеже) ----
(defun xrb-xref-names (doc / lst)
  (setq lst nil)
  (vlax-for b (vla-get-Blocks doc)
    (if (= (vla-get-IsXRef b) :vlax-true)
      (setq lst (cons (vla-get-Name b) lst))))
  (reverse lst))

;; ---- разрешена ли ссылка: бит 32 в флагах блока ----
(defun xrb-resolved-p (nm / e fl)
  (setq e (entget (tblobjname "BLOCK" nm)))
  (if e
    (progn (setq fl (cdr (assoc 70 e)))
           (if (= 32 (logand 32 fl)) T nil))
    nil))

;; ---- это вообще xref-блок? (бит 4) ----
(defun xrb-isxref-p (nm / e fl)
  (setq e (entget (tblobjname "BLOCK" nm)))
  (if e
    (progn (setq fl (cdr (assoc 70 e)))
           (if (= 4 (logand 4 fl)) T nil))
    nil))

(defun xrb-w (f s) (write-line s f))
(defun xrb-pr (s) (princ (strcat "\n" s)))

;; ============================================================
;;  XRLIST — отчёт по ссылкам (без изменений чертежа)
;; ============================================================
(defun c:XRLIST ( / doc names nm f n res tot)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq f (open *xrb-log* "w"))
  (xrb-w f (strcat "Отчёт по внешним ссылкам   " (vla-get-Name doc)))
  (xrb-w f (strcat "Полный путь: " (vla-get-FullName doc)))
  (xrb-w f "-----------------------------------------------")
  (setq names (xrb-xref-names doc))
  (setq tot (length names) n 0)
  (foreach nm names
    (setq n (1+ n))
    (setq res (if (xrb-resolved-p nm) "РАЗРЕШЕНА" "НЕ РАЗРЕШЕНА"))
    (xrb-w f (strcat (itoa n) ".\t" res "\t" nm)))
  (xrb-w f "-----------------------------------------------")
  (xrb-w f (strcat "Всего ссылок: " (itoa tot)))
  (close f)
  (xrb-pr (strcat "XRLIST: ссылок " (itoa tot) " -> " *xrb-log*))
  (xrb-pr "XRLIST_DONE"))

;; ============================================================
;;  XRBIND — внедрить все разрешённые ссылки
;; ============================================================
(defun c:XRBIND ( / doc f names nm before after ok fail skip oldecho oldfiledia)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq f (open *xrb-log* "w"))
  (xrb-w f (strcat "XBIND (внедрение ссылок)   " (vla-get-Name doc)))
  (xrb-w f "-----------------------------------------------")
  (setq oldecho (getvar "CMDECHO"))
  (setq oldfiledia (getvar "FILEDIA"))
  (setvar "CMDECHO" 0)
  (setvar "FILEDIA" 0)

  (setq names (xrb-xref-names doc))
  (setq before (length names))
  (xrb-w f (strcat "Ссылок до операции: " (itoa before)))

  (setq ok 0 fail 0 skip 0)
  (foreach nm names
    (if (xrb-resolved-p nm)
      (progn
        ;; ВНЕДРЕНИЕ: имя + пустой Enter (без него команда виснет на повторном
        ;; запросе списка имён). Проверено на реальном комплекте СПИС.
        (command "_.-XREF" "_B" nm "")
        (if (xrb-resolved-p nm)
          (progn (setq fail (1+ fail))
                 (xrb-w f (strcat "НЕ УДАЛОСЬ\t" nm)))
          (progn (setq ok (1+ ok))
                 (xrb-w f (strcat "ВНЕДРЕНО\t" nm)))))
      (progn (setq skip (1+ skip))
             (xrb-w f (strcat "ПРОПУЩЕНА (не разрешена)\t" nm)))))

  (setq after (length (xrb-xref-names doc)))
  (xrb-w f "-----------------------------------------------")
  (xrb-w f (strcat "Внедрено: " (itoa ok)))
  (xrb-w f (strcat "Не удалось: " (itoa fail)))
  (xrb-w f (strcat "Пропущено (битые): " (itoa skip)))
  (xrb-w f (strcat "Ссылок осталось: " (itoa after) " (было " (itoa before) ")"))
  (close f)

  (setvar "CMDECHO" oldecho)
  (setvar "FILEDIA" oldfiledia)
  (xrb-pr (strcat "XRBIND: внедрено " (itoa ok) ", не удалось " (itoa fail)
                  ", пропущено " (itoa skip) ", осталось " (itoa after)
                  " -> " *xrb-log*))
  (xrb-pr "XRBIND_DONE"))

;; ============================================================
;;  XRBIND1 — внедрить одну ссылку по имени
;; ============================================================
(defun c:XRBIND1 ( / nm oldfiledia)
  (setq nm (getstring T "\nИмя внешней ссылки для внедрения: "))
  (if (and nm (/= nm ""))
    (if (xrb-resolved-p nm)
      (progn
        (setq oldfiledia (getvar "FILEDIA"))
        (setvar "FILEDIA" 0)
        (command "_.-XREF" "_B" nm "")
        (setvar "FILEDIA" oldfiledia)
        (if (xrb-resolved-p nm)
          (xrb-pr (strcat "XRBIND1: не удалось внедрить " nm))
          (xrb-pr (strcat "XRBIND1: внедрено " nm))))
      (xrb-pr (strcat "XRBIND1: ссылка не разрешена или не найдена: " nm)))
    (xrb-pr "XRBIND1: имя не задано"))
  (xrb-pr "XRBIND1_DONE"))

;; ============================================================
;;  XRPATH — сменить путь ссылки (починка «переехавшего» файла)
;; ============================================================
(defun c:XRPATH ( / nm newpath oldfiledia)
  (setq nm (getstring T "\nИмя ссылки, которой меняем путь: "))
  (cond
    ((= nm "") (xrb-pr "XRPATH: имя пустое"))
    ((not (xrb-isxref-p nm)) (xrb-pr "XRPATH: это не внешняя ссылка"))
    (T
      (setq newpath (getstring T "\nНовый полный путь к dwg: "))
      (cond
        ((= newpath "") (xrb-pr "XRPATH: путь пустой — не изменён"))
        ((not (findfile newpath)) (xrb-pr "XRPATH: файл не найден — путь не изменён"))
        (T
          (setq oldfiledia (getvar "FILEDIA"))
          (setvar "FILEDIA" 0)
          (command "_.-XREF" "_P" nm newpath "")
          (setvar "FILEDIA" oldfiledia)
          (if (xrb-resolved-p nm)
            (xrb-pr (strcat "XRPATH: ссылка всё ещё не разрешена: " nm))
            (xrb-pr (strcat "XRPATH: путь обновлён, ссылка разрешена: " nm))
          )
        )
      )
    )
  )
  (xrb-pr "XRPATH_DONE")
)

;; ============================================================
;;  XRUNBIND — ОТСОЕДИНИТЬ только неразрешённые (битые) ссылки.
;;  Главное отличие от Bind: Detach НЕ требует исходного файла,
;;  поэтому берёт и то, чего на диске нет. Именно этим лечится
;;  чертёж, который не привязывается из-за битых вложенных ссылок.
;; ============================================================
(defun c:XRUNBIND ( / doc blks names nm f e ok fail)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq blks (vla-get-Blocks doc))
  (setq f (open *xrb-log* "w"))
  (xrb-w f (strcat "XRUNBIND (отсоединение битых ссылок)   " (vla-get-Name doc)))
  (xrb-w f "-----------------------------------------------")

  ;; ПРОХОД 1 — только чтение: собрать имена НЕразрешённых ссылок.
  ;; Нельзя удалять элементы коллекции, пока по ней идёт vlax-for.
  (setq names nil)
  (vlax-for b blks
    (if (= (vla-get-IsXRef b) :vlax-true)
      (progn
        (setq nm (vla-get-Name b))
        (if (not (xrb-resolved-p nm))
          (setq names (cons nm names))))))
  (setq names (reverse names))
  (xrb-w f (strcat "Битых ссылок найдено: " (itoa (length names))))

  ;; ПРОХОД 2 — удаление по именам
  (setq ok 0 fail 0)
  (foreach nm names
    (setq e (vl-catch-all-apply 'vla-Detach (list (vla-item blks nm))))
    (if (vl-catch-all-error-p e)
      (progn (setq fail (1+ fail))
             (xrb-w f (strcat "ОШИБКА\t" nm "\t" (vl-catch-all-error-message e))))
      (progn (setq ok (1+ ok))
             (xrb-w f (strcat "ОТСОЕДИНЕНО\t" nm)))))

  (xrb-w f "-----------------------------------------------")
  (xrb-w f (strcat "Отсоединено: " (itoa ok) ", ошибок: " (itoa fail)))
  (close f)
  (xrb-pr (strcat "XRUNBIND: отсоединено " (itoa ok) ", ошибок " (itoa fail)
                  " -> " *xrb-log*))
  (xrb-pr "XRUNBIND_DONE"))

;; ============================================================
;;  XRDETACH — отсоединить ВСЕ ссылки (с подтверждением)
;; ============================================================
(defun c:XRDETACH ( / doc blks names nm f e ok fail ans)
  (initget "Да Нет")
  (setq ans (getkword "\nОтсоединить ВСЕ внешние ссылки без внедрения? [Да/Нет] <Нет>: "))
  (if (= ans "Да")
    (progn
      (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq blks (vla-get-Blocks doc))
      (setq f (open *xrb-log* "w"))
      (xrb-w f (strcat "XRDETACH (отсоединение всех ссылок)   " (vla-get-Name doc)))
      (xrb-w f "-----------------------------------------------")

      (setq names (xrb-xref-names doc))   ; проход 1: чтение
      (setq ok 0 fail 0)
      (foreach nm names                   ; проход 2: удаление
        (setq e (vl-catch-all-apply 'vla-Detach (list (vla-item blks nm))))
        (if (vl-catch-all-error-p e)
          (progn (setq fail (1+ fail))
                 (xrb-w f (strcat "ОШИБКА\t" nm)))
          (progn (setq ok (1+ ok))
                 (xrb-w f (strcat "ОТСОЕДИНЕНО\t" nm)))))
      (xrb-w f "-----------------------------------------------")
      (xrb-w f (strcat "Отсоединено: " (itoa ok) ", ошибок: " (itoa fail)))
      (close f)
      (xrb-pr (strcat "XRDETACH: отсоединено " (itoa ok) ", ошибок " (itoa fail)
                      " -> " *xrb-log*)))
    (xrb-pr "XRDETACH: отменено"))
  (xrb-pr "XRDETACH_DONE"))

(princ "\nXRBIND.lsp загружен. Команды: XRBIND  XRBIND1  XRLIST  XRPATH  XRUNBIND  XRDETACH")
(princ)