https://pastein.ru/t/PlD
Загрузка данных
;; ============================================================
;; NVK_COORDS.LSP v3
;; Кодировка: ANSI (CP1251). Сохранять через Блокнот: Файл -> Сохранить как -> Кодировка: ANSI
;; Команда: 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) ; степень IDW (1=линейная, 2=квадратичная)
(setq NVK-ZERO-EPS 0.001) ; минимальное расстояние до соседней точки, ед. чертежа
(setq NVK-MAX-PTS 7) ; максимальное число соседних точек
(setq NVK-COLOR 1) ; цвет объектов (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"))
)
;; Получить центр объекта в МСК (WCS)
(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 arr)
(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 '())
(setq p (nvk:obj-center obj))
(if p
(progn
(setq z (caddr p))
;; Атрибуты блока
(setq attrs (nvk:block-num-attrs obj))
(if attrs
(foreach a attrs
;; Конфликт: Z блока != значение атрибута -> спросить
(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)))
((= (abs z) 0.0)
(setq cands (cons
(list 'VAL (caddr a)
(strcat "Атрибут " (car a) "=" (cadr a)))
cands)))
(t
(setq cands (cons
(list 'VAL (caddr a)
(strcat "Атрибут " (car a) "=" (cadr a)))
cands)))
))
)
;; Нет атрибутов но есть Z вставки блока
(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)
)
;; Разрешить кандидата: вернуть числовое значение или nil
(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)
)
)
;; Главная функция выбора объекта и извлечения значения.
;; Сначала пробуем nentselp (прямой клик), при промахе - ssget в радиусе.
(defun nvk:pick-value (pick / eres obj ename mat cands all ss i en dist p)
;; Попытка прямого клика по объекту (включая XREF)
(setq eres (nentselp "" pick))
(if eres
(progn
(setq ename (car eres))
;; nentselp возвращает ename вложенного объекта; берём его
(setq obj (vlax-ename->vla-object ename))
(setq cands (nvk:candidates-from obj))
;; Проверяем дальность - центр объекта не должен быть дальше NVK-SEARCH-R
(setq 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 '())
(setq 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))
(setq 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 all (strcat "Найдено несколько значений:\n\n") i 1)
(foreach c cands
(setq all (strcat all (itoa i) ". "
(if (= (car c) 'ASK) (cadddr c) (caddr c)) "\n")
i (1+ i)))
(alert all)
(initget 6)
(setq i (getint (strcat "\nНомер [1-" (itoa (length cands)) "]: ")))
(if (and i (>= i 1) (<= i (length cands)))
(nvk:resolve (nth (1- i) cands))
nil))
)
)
;; ==================== СОЗДАНИЕ БЛОКА ====================
(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)))
;; Круг-маркер
(entmake (list '(0 . "CIRCLE") (cons 8 NVK-LAYER) (cons 62 NVK-COLOR)
'(10 0.0 0.0 0.0) (cons 40 (/ NVK-PT-DIAM 2.0))))
;; Штриховка SOLID внутри круга
(entmake (list '(0 . "HATCH")
'(100 . "AcDbEntity") (cons 8 NVK-LAYER) (cons 62 NVK-COLOR)
'(100 . "AcDbHatch")
'(10 0.0 0.0 0.0) '(210 0.0 0.0 1.0)
'(2 . "SOLID") '(70 . 1) '(71 . 0)
'(91 . 1) '(92 . 1) '(72 . 2) '(73 . 1) '(93 . 2)
(cons 10 (list (/ NVK-PT-DIAM 2.0) 0.0 0.0)) (cons 42 1.0)
(cons 10 (list (- (/ NVK-PT-DIAM 2.0)) 0.0 0.0)) (cons 42 1.0)
'(97 . 0) '(75 . 0) '(76 . 1) '(98 . 1) '(10 0.0 0.0 0.0)))
;; Атрибуты (невидимые по умолчанию, видны в палитре Properties)
(setq tp (list 0.0 (+ (/ NVK-PT-DIAM 2.0) NVK-TXT-OFFSET) 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))
)
;; ==================== 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 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 "\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))
(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 "\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 cp (list (car pick) (cadr pick) zval))
(setq pts (append pts (list cp)))
(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 "\nНВК_Координаты v3 загружена. Команда: NVKCOORD")
(princ)
