---

;; ============================================================
;; NVK_COORDS.LSP  v3.6
;; Кодировка: ANSI (CP1251). Блокнот -> Сохранить как -> ANSI
;; Команда: NVKCOORD
;; ============================================================
(vl-load-com)

;; ==================== НАСТРОЙКИ ====================
(setq NVK-LAYER      "НВК_Координаты точек")
(setq NVK-BLOCK-NAME "НВК_Координаты")
(setq NVK-SEARCH-R   2.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")

;; ==================== ВСПОМОГАТЕЛЬНЫЕ ====================
(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) 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)))

;; Очистить строку от MText RTF-кодов вида {\f...|...; текст}
(defun nvk:strip-mtext (s / i c out in-brace depth)
  (if (not s) (setq s ""))
  ;; Если нет { - строка чистая
  (if (not (vl-string-search "{" s))
    s
    ;; Иначе: берём содержимое после последней ; внутри скобок
    (progn
      (setq out "" depth 0 in-brace nil)
      (setq i 0)
      (while (< i (strlen s))
        (setq c (substr s (1+ i) 1))
        (cond
          ((= c "{") (setq depth (1+ depth) in-brace T))
          ((= c "}") (setq depth (max 0 (1- depth))) (if (= depth 0) (setq in-brace nil)))
          ((and in-brace (= c ";"))
           ;; После ; идёт чистый текст до следующего { или }
           (setq out ""))
          ((not in-brace)
           (setq out (strcat out c)))
          ((and in-brace (> depth 0) (not (= c ";")))
           ;; накапливаем после ; 
           nil)
        )
        (setq i (1+ i)))
      (vl-string-trim " " out))))

;; Упрощённый вариант: берём всё что не в скобках и не управляющие символы
(defun nvk:clean-text (s / res i c skip)
  (if (not s) (setq s ""))
  (setq res "" i 0 skip 0)
  (while (< i (strlen s))
    (setq c (substr s (1+ i) 1))
    (cond
      ((= c "{") (setq skip (1+ skip)))
      ((= c "}") (setq skip (max 0 (1- skip))))
      ((= skip 0) (setq res (strcat res c))))
    (setq i (1+ i)))
  ;; Убрать \P и \p (переносы строк MText)
  (setq res (vl-string-subst " " "\\P" res))
  (setq res (vl-string-subst " " "\\p" res))
  (vl-string-trim " " res))

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

(defun nvk:str->num (s / cleaned)
  (setq cleaned (vl-string-trim " " (nvk:clean-text s)))
  (distof (vl-string-subst "." "," cleaned) 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")))

;; ==================== МАРКЕР (круг + SOLID-веер) ====================
(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)
        da (/ (* 2.0 pi) 8.0) rm (* r 0.98) i 0)
  (entmake (list '(0 . "CIRCLE") (cons 8 NVK-LAYER)
                 '(62 . 256) '(6 . "BYLAYER")
                 (cons 10 (list cx cy 0.0)) (cons 40 r)))
  (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))))))

;; ==================== MTEXT (отдельный объект, перемещаемый) ====================
;; Создаём MTEXT вне блока - у него есть собственная ручка для перемещения
;; Угол всегда 0, экструзия (0,0,1) = горизонтальный текст в МСК

(defun nvk:mtext-str (x y z)
  (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 en)
  (setq ins (list (car p)
                  (+ (cadr p) (/ NVK-PT-DIAM 2.0) NVK-TXT-OFFSET)
                  0.0))
  (setq en (entmakex
    (list
      (cons 0 "MTEXT")
      (cons 8 NVK-LAYER)
      (cons 62 256)
      (cons 6 "BYLAYER")
      (cons 100 "AcDbEntity")
      (cons 100 "AcDbMText")
      (cons 10 ins)          ; точка вставки в МСК
      (cons 40 NVK-TXT-HEIGHT)
      (cons 41 0.0)          ; ширина = авто
      (cons 71 1)            ; выравнивание: левый верх
      (cons 72 5)            ; направление: слева направо
      (cons 210 '(0.0 0.0 1.0))  ; экструзия = МСК, угол = 0
      (cons 11 '(1.0 0.0 0.0))   ; вектор X-направления = горизонталь
      (cons 1 (nvk:mtext-str x y z))
      (cons 7 NVK-TEXT-STYLE)
      (cons 90 3)            ; маска фона вкл
      (cons 45 1.1)
      (cons 63 256)
    )))
  en)

(defun nvk:update-mtext (en x y z / ed)
  (if (and en (entget en))
    (progn
      (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:make-block-def (/ tp)
  (if (not (tblsearch "BLOCK" NVK-BLOCK-NAME))
    (progn
      (entmake (list (cons 0 "BLOCK") (cons 2 NVK-BLOCK-NAME) (cons 70 0) (cons 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
          (cons 0 "ATTDEF")
          (cons 100 "AcDbEntity")
          (cons 8 NVK-LAYER)
          (cons 62 256)
          (cons 100 "AcDbText")
          (cons 10 tp)
          (cons 40 NVK-TXT-HEIGHT)
          (cons 1 "")
          (cons 7 NVK-TEXT-STYLE)
          (cons 50 0.0)
          (cons 72 0)
          (cons 11 tp)
          (cons 100 "AcDbAttributeDefinition")
          (cons 280 0)
          (cons 3 tag)
          (cons 2 tag)
          (cons 70 1)     ; невидимый
          (cons 74 0)
          (cons 280 0))))
      (entmake (list (cons 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)))))

;; ==================== ПОИСК (включая заблокированные слои) ====================
(defun nvk:obj-center (en / obj mn mx p1 p2 r)
  (setq r (vl-catch-all-apply
    '(lambda (/ obj)
      (setq obj (vlax-ename->vla-object en))
      (cond
        ((vlax-property-available-p obj 'InsertionPoint)
         (nvk:wcs (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj)))))
        ((vlax-method-applicable-p obj 'GetBoundingBox)
         (vla-GetBoundingBox 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)))
    nil))
  (if (vl-catch-all-error-p r) nil r))

(defun nvk:get-num-vals (en / obj nm out s z)
  ;; Возвращает список числовых значений из объекта
  (setq out '())
  (setq obj (vl-catch-all-apply 'vlax-ename->vla-object (list en)))
  (if (vl-catch-all-error-p obj) (setq obj nil))
  (if obj
    (progn
      (setq nm (vla-get-ObjectName obj))
      (cond
        ;; Блок с атрибутами
        ((and (= nm "AcDbBlockReference")
              (= :vlax-true (vla-get-HasAttributes obj)))
         (foreach a (vlax-safearray->list (vlax-variant-value (vla-GetAttributes obj)))
           (setq s (vla-get-TextString a))
           (if (nvk:numstr-p s)
             (setq out (cons (list (nvk:str->num s)
                               (strcat "Атрибут " (vla-get-TagString a) "=" (nvk:clean-text s)))
                             out))))
         ;; Если нет числовых атрибутов - проверить Z вставки
         (if (null out)
           (progn
             (setq z (caddr (nvk:obj-center en)))
             (if (and z (/= (abs z) 0.0))
               (setq out (list (list z (strcat "Z блока=" (rtos z 2 2)))))))))
        ;; Текст / MTEXT
        ((member nm '("AcDbText" "AcDbMText"))
         (setq s (vla-get-TextString obj))
         (if (nvk:numstr-p s)
           (setq out (list (list (nvk:str->num s) (strcat "Текст=" (nvk:clean-text s)))))))
        ;; Блок без атрибутов - Z
        ((= nm "AcDbBlockReference")
         (setq z (caddr (nvk:obj-center en)))
         (if (and z (/= (abs z) 0.0))
           (setq out (list (list z (strcat "Z=" (rtos z 2 2)))))))
      )))
  out)

(defun nvk:pick-value (pick / all ss i en p dist vals msg idx)
  (setq all '())
  ;; Поиск в квадрате NVK-SEARCH-R вокруг точки клика, все объекты включая заблок.слои
  (setq ss (ssget "_C"
                  (list (- (car pick) NVK-SEARCH-R) (- (cadr pick) NVK-SEARCH-R) 0.0)
                  (list (+ (car pick) NVK-SEARCH-R) (+ (cadr pick) NVK-SEARCH-R) 0.0)))
  (if (null ss)
    ;; Если ssget "_C" не нашёл - пробуем "_X" (все объекты)
    (setq ss (ssget "_X" nil)))
  (if ss
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq en (ssname ss i) p (nvk:obj-center en))
        (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 v (nvk:get-num-vals en)
                (setq all (cons (list dist (car v) (cadr v)) all))))))
        (setq i (1+ i)))))
  (setq all (vl-sort all '(lambda (a b) (< (car a) (car b)))))
  (cond
    ((null all) nil)
    ((= (length all) 1) (cadr (car all)))
    (t
     (setq msg "Найдено несколько значений:\n\n" idx 1)
     (foreach item all
       (setq msg (strcat msg (itoa idx) ". " (caddr item)
                         " (расст.=" (rtos (car item) 2 2) ")\n")
             idx (1+ idx)))
     (alert msg)
     (initget 6)
     (setq idx (getint (strcat "\nНомер [1-" (itoa (length all)) "]: ")))
     (if (and idx (>= idx 1) (<= idx (length all)))
       (cadr (nth (1- idx) all))
       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))
      ;; MTEXT - отдельный объект с собственной ручкой, горизонтальный
      (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" "")
      (if (null mt-en)
        (princ "\n[НВК] Предупреждение: не удалось создать MTEXT"))
      ;; Цикл выбора соседних точек
      (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 (strcat "\n[НВК] Объект не найден в радиусе "
                             (rtos NVK-SEARCH-R 2 1)
                             " ед. Попробуйте ещё раз или ESC.")))
             (t
              (setq pts (append pts (list (list (car pick) (cadr pick) zval))))
              (princ (strcat "\n[НВК] Добавлено значение Z=" (rtos zval 2 3)
                             ", точек: " (itoa (length pts))))
              (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))
                  (princ (strcat "  =>  Z_IDW=" (rtos zw 2 3)))))
              (if (>= (length pts) NVK-MAX-PTS) (setq done T)))))))
      (vla-Update br)))
  (setvar 'CMDECHO olde)
  (princ))

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