https://pastein.ru/t/MID
Загрузка данных
;; ============================================================
;; NVK_COORDS.LSP v3.8
;; ЭТАП 1: только круг + блок + горизонтальный текст
;; Без поиска соседних точек и без расчета Z
;; Кодировка: ANSI (CP1251)
;; Команда: NVKCOORD
;; ============================================================
(vl-load-com)
(setq NVK-LAYER "НВК_Координаты точек")
(setq NVK-BLOCK-NAME "НВК_Координаты")
(setq NVK-PT-DIAM 0.5)
(setq NVK-TXT-HEIGHT 1.0)
(setq NVK-TXT-OFFSET 0.8)
(setq NVK-TEXT-STYLE "Arial")
(setq NVK-TXT-WIDTH 25.0)
(defun nvk:doc () (vla-get-ActiveDocument (vlax-get-acad-object)))
(defun nvk:ms () (vla-get-ModelSpace (nvk:doc)))
(defun nvk:wcs (p) (trans p 1 0))
(defun nvk:ucs (p) (trans p 0 1))
(defun nvk:sa3 (p) (vlax-3d-point (list (car p) (cadr p) (if (caddr p) (caddr p) 0.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: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))
lay)
(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"))
sty)
;; ------------------------------------------------------------
;; КРУГ: рисуем в текущей ПСК, но координаты берём из МСК
;; ------------------------------------------------------------
(defun nvk:draw-marker (pwcs / pucs r cx cy da rm i a1 a2)
(setq pucs (trans pwcs 0 1)
cx (car pucs)
cy (cadr pucs)
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))))))
;; ------------------------------------------------------------
;; БЛОК: только невидимые атрибуты X_COORD Y_COORD
;; Базовая точка = центр круга
;; ------------------------------------------------------------
(defun nvk:make-block-def (/ ok)
(setq ok T)
(if (not (tblsearch "BLOCK" NVK-BLOCK-NAME))
(progn
(if (null (entmake (list '(0 . "BLOCK")
(cons 2 NVK-BLOCK-NAME)
'(70 . 0)
'(10 0.0 0.0 0.0))))
(setq ok nil))
(if ok
(foreach tag '("X_COORD" "Y_COORD")
(if (null
(entmake
(list
'(0 . "ATTDEF")
(cons 8 NVK-LAYER)
'(10 0.0 0.0 0.0)
(cons 40 NVK-TXT-HEIGHT)
'(1 . "")
(cons 3 tag)
(cons 2 tag)
'(70 . 1)
(cons 7 NVK-TEXT-STYLE)
'(72 . 0))))
(setq ok nil)))
(if ok
(if (null (entmake '((0 . "ENDBLK"))))
(setq ok nil)))))
ok)
(defun nvk:insert-block (pwcs / br)
(setq br (vl-catch-all-apply
'vla-InsertBlock
(list (nvk:ms) (nvk:sa3 pwcs) NVK-BLOCK-NAME 1.0 1.0 1.0 0.0)))
(if (vl-catch-all-error-p br)
nil
(progn
(vla-put-Layer br NVK-LAYER)
br)))
(defun nvk:set-att (br tag val)
(if (and br (= :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, чтобы у него была своя ручка перемещения
;; Создаём через ActiveX в МСК и сразу задаём Rotation=0
;; ------------------------------------------------------------
(defun nvk:mtext-str (x y)
(strcat (nvk:fmt-x y) "\n" (nvk:fmt-y x)))
(defun nvk:add-mtext (pwcs x y / ins mt)
(setq ins (list (car pwcs)
(+ (cadr pwcs) (/ NVK-PT-DIAM 2.0) NVK-TXT-OFFSET)
0.0))
(setq mt (vl-catch-all-apply
'vla-AddMText
(list (nvk:ms) (nvk:sa3 ins) NVK-TXT-WIDTH (nvk:mtext-str x y))))
(if (vl-catch-all-error-p mt)
nil
(progn
(vla-put-Layer mt NVK-LAYER)
(vla-put-StyleName mt NVK-TEXT-STYLE)
(vla-put-Height mt NVK-TXT-HEIGHT)
(vl-catch-all-apply 'vla-put-Rotation (list mt 0.0))
(vl-catch-all-apply 'vla-put-AttachmentPoint (list mt 1)) ; верх-лево
(vl-catch-all-apply 'vla-put-BackgroundFill (list mt :vlax-true))
mt)))
;; ------------------------------------------------------------
;; КОМАНДА
;; ------------------------------------------------------------
(defun c:NVKCOORD (/ *error* olde p0 pwcs xw yw ok br mt)
(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)
(setq ok (nvk:make-block-def))
(if (not ok)
(progn
(princ "\n[НВК] Не удалось создать определение блока.")
(setvar 'CMDECHO olde)
(princ))
(progn
(setq p0 (getpoint "\nУкажите базовую точку: "))
(if p0
(progn
(setq pwcs (nvk:wcs p0)
xw (car pwcs)
yw (cadr pwcs))
(nvk:draw-marker pwcs)
(setq br (nvk:insert-block pwcs))
(setq mt (nvk:add-mtext pwcs xw yw))
(if br
(progn
(nvk:set-att br "X_COORD" (nvk:fmt-x yw))
(nvk:set-att br "Y_COORD" (nvk:fmt-y xw))
(princ "\n[НВК] Блок создан."))
(princ "\n[НВК] Блок не создан."))
(if mt
(princ "\n[НВК] Текст создан.")
(princ "\n[НВК] Текст не создан.")))))
(setvar 'CMDECHO olde)
(princ))))
(princ "\nНВК_Координаты v3.8 загружена. Команда: NVKCOORD")
(princ)
