---

;; NVK_COORDS.LSP v3.1
;; Сохранять: Блокнот -> Сохранить как -> Кодировка: ANSI -> имя: nvk_coords.lsp
;; Команда: NVKCOORD
(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 1.0)
(setq NVK-IDW-K      2.0)
(setq NVK-ZERO-EPS   0.001)
(setq NVK-MAX-PTS    7)
(setq NVK-COLOR      1)
(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 / t)
  (and s (> (strlen (setq t (vl-string-trim " " s))) 0)
       (not (vl-catch-all-error-p
             (vl-catch-all-apply 'distof
               (list (vl-string-subst "." "," t) 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)))
  (vla-put-Color lay NVK-COLOR))
(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: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 объекта и значение атрибута не совпадают.

" (cadddr cand)
                            "

Да = взять Z объекта
Нет = взять значение атрибута")
                    "НВК_Координаты")
       (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 "Найдено несколько значений:

" idx 1)
     (foreach c cands
       (setq msg (strcat msg (itoa idx) ". "
                         (if (= (car c) 'ASK) (cadddr c) (caddr c)) "
") idx (1+ idx)))
     (alert msg)
     (initget 6)
     (setq idx (getint (strcat "
Номер [1-" (itoa (length cands)) "]: ")))
     (if (and idx (>= idx 1) (<= idx (length cands)))
       (nvk:resolve (nth (1- idx) cands)) nil))))
(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 nvk:draw-marker (p / ms c h bl)
  (setq ms (nvk:ms))
  (setq c (vla-AddCircle ms (nvk:sa3 p) (/ NVK-PT-DIAM 2.0)))
  (vla-put-Layer c NVK-LAYER)
  (vla-put-Color c NVK-COLOR)
  (setq h (vla-AddHatch ms acHatchPatternTypePredefined "SOLID" :vlax-false))
  (vla-put-Layer h NVK-LAYER)
  (vla-put-Color h NVK-COLOR)
  (setq bl (vlax-make-safearray vlax-vbObject (cons 0 0)))
  (vlax-safearray-put-element bl 0 c)
  (vla-AppendOuterLoop h (vlax-make-variant bl (vlax-vbArray)))
  (vl-catch-all-apply 'vla-Evaluate (list h)))
(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 (list 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)
  (vla-put-Color br NVK-COLOR)
  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: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 mt)
  (setq ins (list (car p) (+ (cadr p) (/ NVK-PT-DIAM 2.0) NVK-TXT-OFFSET) (caddr p)))
  (setq mt (vla-AddMText (nvk:ms) (nvk:sa3 ins) 0.0 (nvk:mtext-str x y z)))
  (vla-put-Layer mt NVK-LAYER)
  (vla-put-Color mt NVK-COLOR)
  (vla-put-StyleName mt NVK-TEXT-STYLE)
  (vla-put-Height mt NVK-TXT-HEIGHT)
  (vla-put-BackgroundFill mt :vlax-true)
  (vl-catch-all-apply 'vla-put-UseBackgroundColor (list mt :vlax-true))
  (vl-catch-all-apply 'vla-put-BackgroundScaleFactor (list mt NVK-MASK-SCALE))
  mt)
(defun nvk:update-mtext (mt x y z)
  (vla-put-TextString mt (nvk:mtext-str x y z))
  (vla-put-BackgroundFill mt :vlax-true))
(defun c:NVKCOORD (/ *error* olde basew br mt pts done pick zval cp zw xw yw)
  (defun *error* (msg)
    (if olde (setvar 'CMDECHO olde))
    (if (and msg (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "
Ошибка: " msg)))
    (princ))
  (setq olde (getvar 'CMDECHO))
  (setvar 'CMDECHO 0)
  (nvk:ensure-layer)
  (nvk:ensure-style)
  (nvk:make-block-def)
  (setq basew (getpoint "
Укажите базовую точку: "))
  (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 (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 "
ESC - выход, укажите соседнюю высотную точку: "))
        (cond
          ((null pick) (setq done T))
          (t
           (setq pick (nvk:wcs pick) zval (nvk:pick-value pick))
           (cond
             ((null zval)
              (princ "
[НВК] Данные не найдены. Попробуйте ещё раз или нажмите 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 xw yw zw)
                  (nvk:set-att br "Z_COORD" (nvk:fmt-z zw))))
              (if (>= (length pts) NVK-MAX-PTS) (setq done T)))))))
      (vla-Update mt)
      (vla-Update br)))
  (setvar 'CMDECHO olde)
  (princ))
(princ "
НВК_Координаты v3.1 загружена. Команда: NVKCOORD")
(princ)