---

;; ============================================================
;; NVK_COORDS.LSP  v3.4
;; Кодировка: ANSI (CP1251). Блокнот -> Сохранить как -> ANSI
;; Команда: NVKCOORD
;; Исправлено:
;;   - перенос строк в MTEXT через entmake (DXF код 1) вместо "\P"
;;   - маска фона через entmake DXF 90/45/63 - без vla-put-usebackgroundcolor
;;   - MTEXT ставится строго над центром круга
;; ============================================================
(vl-load-com)

;; ==================== НАСТРОЙКИ ====================
(setq NVK-LAYER      "НВК_Координаты точек")
(setq NVK-BLOCK-NAME "НВК_Координаты")
(setq NVK-SEARCH-R   1.0)
(setq NVK-PT-DIAM    0.5)
(setq NVK-TXT-HEIGHT 1.0)
(setq NVK-TXT-OFFSET 0.8)
(setq NVK-IDW-K      2.0)
(setq NVK-ZERO-EPS   0.001)
(setq NVK-MAX-PTS    7)
(setq NVK-TEXT-STYLE "Arial")
(setq NVK-MASK-SCALE 1.1)

;; ==================== ВСПОМОГАТЕЛЬНЫЕ ====================
(defun nvk:doc () (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun nvk:ms  () (vla-get-ModelSpace (nvk:doc)))
(defun nvk:sa3 (p) (vlax-3d-point (list (car p) (cadr p) (if (caddr p) (caddr p) 0.0))))
(defun nvk:wcs (p) (trans p 1 0))

(defun nvk:rtos2 (v / s)
  (setq s (vl-string-subst "," "." (rtos (abs v) 2 2)))
  (strcat (if (minusp v) "-" "+") s))

(defun nvk:fmt-x (v) (strcat "X= " (nvk:rtos2 v)))
(defun nvk:fmt-y (v) (strcat "Y= " (nvk:rtos2 v)))
(defun nvk:fmt-z (v) (strcat "Z= " (nvk:rtos2 v)))

(defun nvk:numstr-p (s / tt)
  (and s (> (strlen (setq tt (vl-string-trim " " s))) 0)
       (not (vl-catch-all-error-p
             (vl-catch-all-apply 'distof
               (list (vl-string-subst "." "," tt) 2))))))

(defun nvk:str->num (s)
  (distof (vl-string-subst "." "," (vl-string-trim " " s)) 2))

(defun nvk:yesno (msg ttl / sh r)
  (setq sh (vlax-create-object "WScript.Shell"))
  (setq r (vlax-invoke sh 'Popup msg 0 ttl (+ 4 32)))
  (vlax-release-object sh)
  (= r 6))

(defun nvk:ensure-layer (/ lc lay)
  (setq lc (vla-get-Layers (nvk:doc)))
  (if (tblsearch "LAYER" NVK-LAYER)
    (setq lay (vla-Item lc NVK-LAYER))
    (setq lay (vla-Add lc NVK-LAYER)))
  (if (= (vla-get-Color lay) 7) (vla-put-Color lay 1)))

(defun nvk:ensure-style (/ sc sty)
  (setq sc (vla-get-TextStyles (nvk:doc)))
  (if (tblsearch "STYLE" NVK-TEXT-STYLE)
    (setq sty (vla-Item sc NVK-TEXT-STYLE))
    (setq sty (vla-Add sc NVK-TEXT-STYLE)))
  (vl-catch-all-apply 'vla-put-FontFile (list sty "arial.ttf")))

;; ==================== МАРКЕР ====================
(defun nvk:draw-marker (p / r cx cy da rm i a1 a2)
  (setq cx (car p) cy (cadr p) r (/ NVK-PT-DIAM 2.0))
  (entmake (list '(0 . "CIRCLE")
                 (cons 8 NVK-LAYER)
                 '(62 . 256) '(6 . "BYLAYER")
                 (cons 10 (list cx cy 0.0))
                 (cons 40 r)))
  (setq da (/ (* 2.0 pi) 8.0) rm (* r 0.98) i 0)
  (repeat 8
    (setq a1 (* i da) a2 (* (1+ i) da) i (1+ i))
    (entmake (list '(0 . "SOLID")
                   (cons 8 NVK-LAYER)
                   '(62 . 256) '(6 . "BYLAYER")
                   (cons 10 (list (+ cx (* rm (cos a1))) (+ cy (* rm (sin a1))) 0.0))
                   (cons 11 (list (+ cx (* rm (cos a2))) (+ cy (* rm (sin a2))) 0.0))
                   (cons 12 (list cx cy 0.0))
                   (cons 13 (list cx cy 0.0))))))

;; ==================== ОПРЕДЕЛЕНИЕ БЛОКА ====================
(defun nvk:make-block-def (/ tp)
  (if (not (tblsearch "BLOCK" NVK-BLOCK-NAME))
    (progn
      (entmake (list '(0 . "BLOCK") (cons 2 NVK-BLOCK-NAME) '(70 . 0) '(10 0.0 0.0 0.0)))
      (setq tp '(0.0 0.0 0.0))
      (foreach tag '("X_COORD" "Y_COORD" "Z_COORD")
        (entmake (list '(0 . "ATTDEF") (cons 8 NVK-LAYER)
                       '(100 . "AcDbEntity") '(100 . "AcDbText")
                       (cons 10 tp) (cons 40 NVK-TXT-HEIGHT) (cons 1 "")
                       (cons 7 NVK-TEXT-STYLE) (cons 72 0) (cons 11 tp)
                       '(100 . "AcDbAttributeDefinition")
                       (cons 3 tag) (cons 2 tag) (cons 70 1) (cons 74 2))))
      (entmake '((0 . "ENDBLK"))))))

(defun nvk:insert-block (p / br)
  (setq br (vla-InsertBlock (nvk:ms) (nvk:sa3 p) NVK-BLOCK-NAME 1.0 1.0 1.0 0.0))
  (vla-put-Layer br NVK-LAYER)
  br)

(defun nvk:set-att (br tag val)
  (if (= :vlax-true (vla-get-HasAttributes br))
    (foreach a (vlax-safearray->list (vlax-variant-value (vla-GetAttributes br)))
      (if (= (strcase (vla-get-TagString a)) (strcase tag))
        (vla-put-TextString a val)))))

;; ==================== MTEXT через entmake ====================
;; DXF 90: флаги маски фона (бит 1=включена, бит 2=цвет фона)
;; DXF 45: масштаб рамки маски (>= 1.0)
;; DXF 63: цвет маски (256 = по слою/фону)
;; Перенос строк в DXF коде 1: символ \P (в entmake нужен реальный \n в строке кода)

(defun nvk:mtext-str (x y z)
  ;; Формируем строку с переносом через \P (MTEXT-коды)
  (if z
    (strcat (nvk:fmt-x y) "\\P" (nvk:fmt-y x) "\\P" (nvk:fmt-z z))
    (strcat (nvk:fmt-x y) "\\P" (nvk:fmt-y x))))

(defun nvk:add-mtext (p x y z / ins ename)
  (setq ins (list (car p)
                  (+ (cadr p) (/ NVK-PT-DIAM 2.0) NVK-TXT-OFFSET)
                  (caddr p)))
  (entmake (list '(0 . "MTEXT")
                 (cons 8 NVK-LAYER)
                 '(62 . 256) '(6 . "BYLAYER")
                 (cons 10 ins)           ; точка вставки
                 (cons 40 NVK-TXT-HEIGHT) ; высота текста
                 (cons 41 0.0)           ; ширина = 0 (авто)
                 (cons 71 1)             ; выравнивание: левый верх
                 (cons 72 5)             ; направление: слева направо
                 (cons 1 (nvk:mtext-str x y z)) ; текст с \P
                 (cons 7 NVK-TEXT-STYLE)
                 ;; Маска фона:
                 (cons 90 3)             ; 1+2: маска вкл + цвет фона чертежа
                 (cons 45 NVK-MASK-SCALE) ; масштаб рамки
                 (cons 63 256)           ; цвет маски = фон чертежа
                 ))
  (entlast))

(defun nvk:update-mtext (en x y z / ed)
  (setq ed (entget en))
  (setq ed (subst (cons 1 (nvk:mtext-str x y z))
                  (assoc 1 ed) ed))
  (entmod ed)
  (entupd en))

;; ==================== ПОИСК ДАННЫХ ====================
(defun nvk:obj-center (obj / mn mx p1 p2)
  (cond
    ((vlax-property-available-p obj 'InsertionPoint)
     (nvk:wcs (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj)))))
    ((and (vlax-method-applicable-p obj 'GetBoundingBox)
          (not (vl-catch-all-error-p
                (vl-catch-all-apply 'vla-GetBoundingBox (list obj 'mn 'mx)))))
     (setq p1 (vlax-safearray->list mn) p2 (vlax-safearray->list mx))
     (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2))
    (t nil)))

(defun nvk:block-num-attrs (obj / out)
  (setq out '())
  (if (and (= (vla-get-ObjectName obj) "AcDbBlockReference")
           (= :vlax-true (vla-get-HasAttributes obj)))
    (foreach a (vlax-safearray->list (vlax-variant-value (vla-GetAttributes obj)))
      (if (nvk:numstr-p (vla-get-TextString a))
        (setq out (cons (list (vla-get-TagString a)
                              (vla-get-TextString a)
                              (nvk:str->num (vla-get-TextString a))) out)))))
  (reverse out))

(defun nvk:text-num (obj / s)
  (and (member (vla-get-ObjectName obj) '("AcDbText" "AcDbMText"))
       (nvk:numstr-p (setq s (vla-get-TextString obj)))
       (list s (nvk:str->num s))))

(defun nvk:candidates-from (obj / p z attrs tv cands)
  (setq cands '() p (nvk:obj-center obj))
  (if p
    (progn
      (setq z (caddr p) attrs (nvk:block-num-attrs obj))
      (if attrs
        (foreach a attrs
          (cond
            ((and (/= (abs z) 0.0) (not (equal z (caddr a) 0.01)))
             (setq cands (cons (list 'ASK z (caddr a)
                                (strcat "Блок Z=" (rtos z 2 2) " | Атрибут " (car a) "=" (cadr a)))
                               cands)))
            (t (setq cands (cons (list 'VAL (caddr a)
                                  (strcat "Атрибут " (car a) "=" (cadr a))) cands))))))
      (if (and (null attrs) (= (vla-get-ObjectName obj) "AcDbBlockReference") (/= (abs z) 0.0))
        (setq cands (cons (list 'VAL z (strcat "Z блока=" (rtos z 2 2))) cands)))
      (setq tv (nvk:text-num obj))
      (if tv (setq cands (cons (list 'VAL (cadr tv) (strcat "Текст=" (car tv))) cands)))))
  (reverse cands))

(defun nvk:resolve (cand)
  (cond
    ((null cand) nil)
    ((= (car cand) 'ASK)
     (if (nvk:yesno (strcat "Z и атрибут не совпадают.\n\n" (cadddr cand)
                            "\n\nДа = Z объекта\nНет = значение атрибута")
                    "НВК_Координаты")
       (cadr cand) (caddr cand)))
    ((= (car cand) 'VAL) (cadr cand))
    (t nil)))

(defun nvk:pick-value (pick / eres ename obj cands all ss i en dist p msg idx)
  (setq eres (nentselp "" pick))
  (if eres
    (progn
      (setq ename (car eres) obj (vlax-ename->vla-object ename)
            cands (nvk:candidates-from obj) p (nvk:obj-center obj))
      (if (and p (> (distance (list (car pick) (cadr pick) 0.0)
                               (list (car p)  (cadr p)  0.0)) NVK-SEARCH-R))
        (setq cands '())))
    (progn
      (setq cands '() all '())
      (setq ss (ssget "_C"
                      (list (- (car pick) NVK-SEARCH-R) (- (cadr pick) NVK-SEARCH-R))
                      (list (+ (car pick) NVK-SEARCH-R) (+ (cadr pick) NVK-SEARCH-R))))
      (if ss
        (progn
          (setq i 0)
          (repeat (sslength ss)
            (setq en (ssname ss i) obj (vlax-ename->vla-object en) p (nvk:obj-center obj))
            (if p
              (progn
                (setq dist (distance (list (car pick) (cadr pick) 0.0)
                                      (list (car p)  (cadr p)  0.0)))
                (if (<= dist NVK-SEARCH-R)
                  (foreach c (nvk:candidates-from obj)
                    (setq all (cons (list dist c) all))))))
            (setq i (1+ i)))
          (setq all (vl-sort all '(lambda (a b) (< (car a) (car b)))))
          (if all (setq cands (list (cadr (car all)))))))))
  (cond
    ((null cands) nil)
    ((= (length cands) 1) (nvk:resolve (car cands)))
    (t
     (setq msg "Найдено несколько значений:\n\n" idx 1)
     (foreach c cands
       (setq msg (strcat msg (itoa idx) ". "
                         (if (= (car c) 'ASK) (cadddr c) (caddr c)) "\n") idx (1+ idx)))
     (alert msg)
     (initget 6)
     (setq idx (getint (strcat "\nНомер [1-" (itoa (length cands)) "]: ")))
     (if (and idx (>= idx 1) (<= idx (length cands)))
       (nvk:resolve (nth (1- idx) cands)) nil))))

;; ==================== IDW ====================
(defun nvk:idw (base pts / num den d z)
  (setq num 0.0 den 0.0)
  (foreach p pts
    (setq d (distance (list (car base) (cadr base) 0.0) (list (car p) (cadr p) 0.0))
          z (caddr p))
    (if (< d NVK-ZERO-EPS)
      (progn (setq num z den 1.0) (setq pts nil))
      (progn (setq num (+ num (/ z (expt d NVK-IDW-K))))
             (setq den (+ den (/ 1.0 (expt d NVK-IDW-K)))))))
  (if (> den 0.0) (/ num den)))

;; ==================== ГЛАВНАЯ КОМАНДА ====================
(defun c:NVKCOORD (/ *error* olde basew br mt-en pts done pick zval zw xw yw)
  (defun *error* (msg)
    (if olde (setvar 'CMDECHO olde))
    (if (and msg (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nОшибка: " msg)))
    (princ))
  (setq olde (getvar 'CMDECHO))
  (setvar 'CMDECHO 0)
  (nvk:ensure-layer)
  (nvk:ensure-style)
  (nvk:make-block-def)
  (setq basew (getpoint "\nУкажите базовую точку: "))
  (if basew
    (progn
      (setq basew (nvk:wcs basew)
            xw    (car  basew)
            yw    (cadr basew))
      (nvk:draw-marker basew)
      (setq br    (nvk:insert-block basew))
      (setq mt-en (nvk:add-mtext basew xw yw nil))
      (nvk:set-att br "X_COORD" (nvk:fmt-x yw))
      (nvk:set-att br "Y_COORD" (nvk:fmt-y xw))
      (nvk:set-att br "Z_COORD" "")
      (setq pts '() done nil)
      (while (not done)
        (setq pick (getpoint "\nESC - выход, укажите соседнюю точку: "))
        (cond
          ((null pick) (setq done T))
          (t
           (setq pick (nvk:wcs pick)
                 zval (nvk:pick-value pick))
           (cond
             ((null zval)
              (princ "\n[НВК] Данные не найдены. Попробуйте ещё раз или нажмите ESC."))
             (t
              (setq pts (append pts (list (list (car pick) (cadr pick) zval))))
              (if (>= (length pts) 2)
                (progn
                  (setq zw (nvk:idw basew pts))
                  (nvk:update-mtext mt-en xw yw zw)
                  (nvk:set-att br "Z_COORD" (nvk:fmt-z zw))))
              (if (>= (length pts) NVK-MAX-PTS) (setq done T)))))))
      (vla-Update br)))
  (setvar 'CMDECHO olde)
  (princ))

(princ "\nНВК_Координаты v3.4 загружена. Команда: NVKCOORD")
(princ)