Сергей пишет:"Объект назначения удален. Деактивируем реактор".
Это наверное громко сказано. На самом деле, если нет объекта, куда записывать сумму, то и сама цепочка не имеет смысла. Дективируется реатор этой цепочки. Остальные работают. Исправлять ничего не надо.
Теперь о блоках.
Ты когда создаешь блок в Автокаде, то в диалоговом окне есть радио-кнопки "Оставить" "Сделать блоком" "Удалить". Это к тому, что в блок посылается копия выбранных объектов, а исходные в зависимости от ответа:
"Оставить" - остаются на месте
"Сделать блоком" - удалябтся, на их место вставляется блок
"Удалить" - удаляются.
С точки зрения копирования объектов абсолютно без разницы, копировать их из пространства модели в пространство блока или из пространства модели одного чертежа в пространство модели другого чертежа. Главное здесть КОПИРОВАТЬ
При втавке блока
(примитивы) получают новые метки и связи уже нет :(
Исправил пару ошибок
;https://www.caduser.ru/forum/topic33835.html
(defun mip_mtext_unformat ( Mtext / text Str )(setq Text "")
(while (/= Mtext "")
(cond ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
(setq Mtext (substr Mtext 3) Text (strcat Text Str)))
((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
(setq Mtext (substr Mtext 3)))
((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
(setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
((wcmatch (strcase (substr Mtext 1 2)) "\\P")
(if (or(= " " (substr Text (strlen Text)))(= " " (substr Mtext 3 1)))
(setq Mtext (substr Mtext 3))(setq Mtext (substr Mtext 3) Text (strcat Text " "))))
((wcmatch (strcase (substr Mtext 1 2)) "\\S")
(setq Str (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
Mtext (substr Mtext (+ 4 (strlen Str)))))
(t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))
)) Text)
(defun sumT-in-reac ( K vla-list-owner / res selset ins_pt txt_height str)
(setq res 0.)
(setq vla-list-owner (vl-remove-if 'vlax-erased-p vla-list-owner))
(foreach ent vla-list-owner
(if (vlax-read-enabled-p ent)(progn
(setq str (mip_mtext_unformat (vla-get-textstring ent))
str (vl-string-translate "," "." (vl-string-trim "%UuoOcC \t" str))
str (vl-string-trim "%UuoOcC \t" str) res (+ res (atof str))))))
(setq res (* K res))
; (princ "\nРезультат=")(princ (rtos res 2))
res)
(defun add_sumt_object_reactor ( vla-list-owner vla-dest / reac )
(setq vla-list-owner (vl-remove vla-dest vla-list-owner))
(setq reac (vlr-object-reactor vla-list-owner (list '("Rname" "SumT")(list "DEST" (vla-get-Handle vla-dest)))
(list '(:vlr-modified . SumT_Reaction) )))
(vlr-pers reac)(SumT_ReactionUpd reac))
(defun SumT_Reaction (vlao reac args / vla-dest ht dat en lst)
(vl-load-com)
(if (vlr-added-p reac)(progn
(setq dat (vlr-data reac))
(if (and
(= (cadr (assoc "Rname" dat)) "SumT")
(setq ht (cadr (assoc "DEST" dat)))
(setq en (handent ht))
(entget en)
(setq vla-dest (vlax-ename->vla-object en)))
(if (vlax-write-enabled-p vla-dest)
(progn
(if (member vlao (setq lst (vlr-owners reac)))
(progn
(VLR-Owner-Remove reac vla-dest)
(setq ht (sumT-in-reac 1 lst))
(vla-put-TextString vla-dest (rtos ht 2 2))
)
)
)
(princ "\nТекст на заблокированном слое - сумму не меняем")
)
(progn
(princ "\nОбъект назначения удален. Деактивируем реактор")
(vlr-remove reac)
(mapcar '(lambda(x)(VLR-Owner-Remove reac x))(vlr-owners reac))))))
)
(defun mip-reg-get-path ()"HKEY_LOCAL_MACHINE\\Software\\MIP")
(defun mip-reg-write (key value )
(vl-registry-write (mip-reg-get-path)
(vl-princ-to-string key)(vl-princ-to-string value)))
(defun mip-reg-read ( key )(vl-registry-read (mip-reg-get-path)
(vl-princ-to-string key)))
(defun mip-conv-to-str (dat)(if dat (vl-princ-to-string dat) ""))
(defun SumT_ReactionUpd (reac / vla-dest ht dat en lst)
(vl-load-com)
(if (vlr-added-p reac)
(progn
(setq dat (vlr-data reac))
(if (and
(= (cadr (assoc "Rname" dat)) "SumT")
(setq ht (cadr (assoc "DEST" dat)))
(setq en (handent ht))
(entget en)
(setq vla-dest (vlax-ename->vla-object en))
)
(if (vlax-write-enabled-p vla-dest)
(progn
(VLR-Owner-Remove reac vla-dest)
(setq ht (sumT-in-reac 1 (vlr-owners reac)))
(vla-put-TextString vla-dest (rtos ht 2 2))
;(setq RR reac)
)
(princ "\nТекст не заблокированном слое")
)
(progn
(princ "\nОбъект назначения удален. Деактивируем реактор цепочки")
(vlr-remove reac)
(mapcar '(lambda(x)(VLR-Owner-Remove reac x))(vlr-owners reac))))))
)
(defun sumt_del ( dst / reac-list)
(setq reac-list (vl-remove-if-not '(lambda(reac)(member dst (vlr-owners reac)))(vlr-pers-list)))
(mapcar '(lambda (reac)(VLR-Owner-Remove reac dst)) reac-list)
(mapcar 'SumT_ReactionUpd (reverse reac-list)))
(defun SetSumTColor ( / colP colS)
(alert "Цвет слагаемого текста:")
(setq colP (ACAD_COLORDLG 1 nil))
(if (null colP)(setq colP 1))
(alert "Цвет суммы текста:")
(setq colS (ACAD_COLORDLG 5 nil))
(if (null colS)(setq colS 5))
(mip-reg-write "SumT_Color+"(mip-conv-to-str colP))
(mip-reg-write "SumT_Color="(mip-conv-to-str colS))
)
(defun GetSumTColor ( / ht )(list
(if (setq ht (mip-reg-read "SumT_Color+")) ht 1)
(if (setq ht (mip-reg-read "SumT_Color=")) ht 5)))
(defun getcolorlist (obj / TrueColor)
(if (vlax-erased-p obj) nil
(list obj
(if (= (vla-get-colormethod
(setq TrueColor (vla-get-truecolor obj))
) ;_ end of vla-get-colormethod
accolormethodbyrgb
) ;_ end of =
(list (vla-get-red TrueColor)
(vla-get-green TrueColor)
(vla-get-blue TrueColor)
) ;_ end of list
(vla-get-color obj)
) ;_ end of if
) ;_ end of list
)
) ;_ end of defun
(defun Restorecolorlist ( / TrueColor)
(princ "\nВосстанавливаю цвет текста ... ")
(foreach item *sumT-obj-list*
(if item
(vl-catch-all-apply (function (lambda ( / obj xx)
(setq TrueColor (vla-get-TrueColor (setq obj (nth 0 item))))
(setq xx (nth 1 item))
(if (listp xx)(progn
(vla-setRGB TrueColor (nth 0 xx) (nth 1 xx) (nth 2 xx))
(vla-put-TrueColor obj TrueColor))
(vla-put-color obj xx)))))
)
)
(setq *sumT-obj-list* nil)
(princ " ok")(princ)
)
(defun SumT_Viz ( obj / reac-list owner-list sum-list colP colS)
(or *kpblc-activedoc*
(setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
)
(vla-startundomark *kpblc-activedoc*)
(setq reac-list (vl-remove-if-not '(lambda(reac)(member dst (vlr-owners reac)))(vlr-pers-list)))
(setq owner-list (mapcar 'vlr-owners reac-list))
(setq owner-list (apply 'append owner-list))
(setq sum-list (mapcar '(lambda (reac / dat ht en vla-dest)
(if (vlr-added-p reac)
(progn
(setq dat (vlr-data reac))
(if (and
(= (cadr (assoc "Rname" dat)) "SumT")
(setq ht (cadr (assoc "DEST" dat)))
(setq en (handent ht))
(entget en)
(setq vla-dest (vlax-ename->vla-object en))
(vlax-write-enabled-p vla-dest)
)
vla-dest
nil
)))) reac-list))
(setq sum-list (vl-remove-if 'null sum-list))
(foreach item sum-list (setq owner-list (vl-remove item owner-list)))
(setq colP (mapcar 'atoi (GetSumTColor))
colS (cadr colP)
colP (car colP)
)
(setq *sumT-obj-list* (append *sumT-obj-list* (mapcar 'getcolorlist owner-list))
*sumT-obj-list* (append *sumT-obj-list* (mapcar 'getcolorlist sum-list))
)
(mapcar '(lambda(x)(if (vlax-write-enabled-p x)(vla-put-Color x colP))) owner-list)
(mapcar '(lambda(x)(if (vlax-write-enabled-p x)(vla-put-Color x colS))) sum-list)
(vla-endundomark *kpblc-activedoc*)
(princ "\nКоманда SumT_VizR восстановит цвет текста ")
(princ)
)
;;Создает связь между текстами автовычисления и приемником
(defun C:SumT_Creat ( / dst selset)
(vl-load-com)
(while (null dst)
(princ "\nУкажите текст-приемник (для отображения суммы)")
(setq dst (ssget "_+.:S:E:L" '((0 . "*TEXT")))))
(setq dst (ssname dst 0)
dst (vlax-ename->vla-object dst)
)
(princ "\nВыберите тексты-источники для суммирования")
(if (setq selset (ssget "_:L" '((0 . "*TEXT"))))
(add_sumt_object_reactor (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
dst)
)
(princ)
)
;_Добавляет текст к существующей цепочке автосуммы
(defun C:SumT_Add ( / dst reac-list selset lst *error*)
(defun *error* (msg)(princ msg)(Restorecolorlist)(princ))
(vl-load-com)
(while (not(progn
(princ "\nУкажите текст существующей связи")
(if (setq dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
(setq dst (ssname dst 0)
dst (vlax-ename->vla-object dst)
)
)
(setq reac-list (vl-remove-if-not '(lambda(reac)(member dst (vlr-owners reac)))(vlr-pers-list)))
(if (null reac-list)
(princ "\nТекст не выбран или не зарегестрирована цепочка суммирования"))
reac-list)))
(setq lst (vl-remove-if 'null (mapcar 'car (mapcar 'vlr-owners reac-list))))
(mapcar 'SumT_Viz lst)
(princ "\nВыберите тексты для добавления к цепи")
(if (setq selset (ssget "_:L" '((0 . "*TEXT"))))
(progn
(mapcar '(lambda (obj)(vlr-owner-add (last reac-list) obj))(mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))))
(mapcar 'SumT_ReactionUpd (reverse reac-list))
)
)
(Restorecolorlist)
(princ)
)
;;Удаляет текст из связи
(defun C:SumT_Del1 ( / dst )
(vl-load-com)
(princ "\nУкажите текст для удаления из цепочки")
(if (setq dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
(progn
(setq dst (ssname dst 0)
dst (vlax-ename->vla-object dst)
)
(sumt_del dst)
)
)
(princ)
)
;;Удаляет тексты из связи
(defun C:SumT_Del ( / dst )
(vl-load-com)
(princ "\nУкажите тексты для удаления из цепочки")
(if (setq dst (ssget "_:L" '((0 . "*TEXT"))))
(progn
(mapcar 'sumt_del (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex dst)))))
)
)
(princ)
)
;;;Задание цвета цепочке и сумме
(defun C:SumT_Color ()(SetSumTColor)(princ))
;;Визуализирует связь
(defun C:SumT_Viz ( / dst reac-list owner-list sum-list colP colS)
(vl-load-com)
(princ "\nУкажите текст для визуализации цепочки ")
(if (setq dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
(progn
(setq dst (ssname dst 0)
dst (vlax-ename->vla-object dst)
)
(SumT_Viz dst)
)
)
(princ)
)
;;Восстанавлиает предыдущее состояние
(defun C:SumT_VizR ( )(Restorecolorlist))
(mapcar 'princ (list
"\n ==== Определенные команды ===="
"\nSumT_Creat - Создает связь между текстами автосуммирования (слагаемыми) и тектсом - приемником (суммой)"
"\nSumT_Add - Добавляет текст к существующей цепочке автосуммы"
"\nSumT_Del1 - Удаляет текст из связи"
"\nSumT_Del - Удаляет тексты из связи"
"\nSumT_Color - Задание цвета цепочке и сумме"
"\nSumT_Viz - Визуализирует связь"
"\nSumT_VizR - Восстанавлиает предыдущее состояние"))
(princ)
