Тема: Пересчет вычислений продолжение

Начало темы https://www.caduser.ru/forum/topic33835.html
Мнение работы программы пересчет автосуммы !!
Помогите доделать лисп!!!
Не решена проблемма: Код постоянно загружен, но при копировании всей цепочки пересчета на другой dwg файл пересчет не работает, соответственно при вставке блока в котором есть вся цепочка пересчета тоже не работает!
Даже если вырезать всю цепочку и вставить тоже не работает!!
Значит как говорит

> VVA
по поводу Копирования то дело не в этом!!
(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)

Re: Пересчет вычислений продолжение

Найден есчо один недостаток
Действия
Вырезаем всю цепочку пересчета, вставляем пересчет не работает!!
И ПРИ ВОЗВРАТЕ ДЕЙСТВИЙ "вырезать" и "вставить" выдает ошибку
; error: Automation Error. Description was not provided.
и соответственно пересчет не работает!!

Re: Пересчет вычислений продолжение

;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 '("SumTRname" "SumT")(list "SumTDEST" (vla-get-Handle vla-dest)))
    (list '(:vlr-modified . SumT_Reaction) )))
  (vlr-pers reac)(_add-SumT-RD vla-list-owner vla-dest)
  (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 "SumTRname" dat)) "SumT")
     (setq ht (cadr (assoc  "SumTDEST" 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 "SumTRname" dat)) "SumT")
     (setq ht (cadr (assoc  "SumTDEST" 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))
  (_del-SumT-RD  (vlax-vla-object->ename dst))
    )
(defun _del-SumT-RD (e1)
  (mapcar '(lambda(x)(_del_txt_dictxd e1 x))
          (vl-remove-if-not '(lambda(x)(wcmatch x "SumT*"))
            (mapcar 'car (car(lib:massoc -3 (entget e1 '("*")))))))
  )
(defun _add-SumT-RD ( vla-list-owner vla-dest / currRDName)
  (setq vla-list-owner (mapcar 'vlax-vla-object->ename vla-list-owner))
  (setq vla-dest (vlax-vla-object->ename vla-dest))
  (setq currRDName (_get_txt_dictxdName))
  (mapcar '(lambda(x)(_add_txt_dictxd x currRDName "0")) vla-list-owner)
  (_add_txt_dictxd vla-dest currRDName "1")
  )
(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 "SumTRname" dat)) "SumT")
     (setq ht (cadr (assoc  "SumTDEST" 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 lib:massoc (key alist)
 (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
;;;================================================================================
;;; Функция добавляет Расширенные Данные к примитиву
;;; (-3 ("MIP_XD" (1000 . DICT)(1005.METKA)))
;;; DICT - имя словаря примитива (строка)
;;; ELIST - Полный список {(setq ELIST (entget ENAME (list "MIP_XD")))}
;;; ENAME - Имя примитива
;;; RNAME - имя приложения
(DEFUN _add_txt_dictxd
       (ENAME RNAME DICT  / XDLIST ELIST METKA XD_ENT XD_LIST3)
;;; Имя приложени
  (regapp RNAME)
  (setq ELIST (entget ENAME '("*")))
  (setq METKA (cdr (assoc 5 ELIST)))
;;; ======== Сформировать список РАСШИРЕННЫХ ДАННЫХ
  (setq XDLIST (list (cons 1000 DICT)(cons 1005 METKA)))
;;; Добавить имя приложения в начало списка Рданных.
  (setq XDLIST (list (cons RNAME XDLIST)))
;;; Добавить код группы -3 перед списком расширенных данных.
  (setq XDLIST (cons -3 XDLIST))
;;;(princ "\nXDLIST=")(princ XDLIST)
  ;; Теперь список расширенных данных добавлен к данным примитива. Сложнее,
  ;; если примитив уже имеет Рданные. Следует также проверить достаточность
  ;; пространства для Рданных.
  (if (< (xdsize XDLIST) (xdroom ENAME)); Если есть еще пространство...
    (progn
      (if (assoc -3 ELIST)        ; и уже есть Рданные...
    (progn
      (setq XDLIST (cdr XDLIST))    ; Новые Рданные.
      (setq XD_ENT (cdr (assoc -3 ELIST))) ; Старые Рданные.
      ;; Найти старые Рданные для того же приложени
      (if (assoc RNAME XD_ENT)
        (progn
          ;; Поместить обратно в существующий список Рданных
          (setq XD_LIST3 (subst (car XDLIST)
                    (assoc RNAME XD_ENT)
                    (assoc -3 ELIST)
                 ) ;_ End of subst
          ) ;_ End of setq
        ) ;_ End of progn
        (progn            ; Это новое приложение...
          (setq XDLIST (append XD_ENT XDLIST))
                    ; Объединить Рданные.
          (setq XD_LIST3 (cons -3 XDLIST))
        ) ;_ End of progn
      ) ;_if assoc RNAME
      (setq ELIST (subst XD_LIST3 (assoc -3 ELIST) ELIST))
                    ; Объединить с примитивом
    ) ;_progn
    (setq ELIST (cons XDLIST ELIST)) ; Пока нет Рданных.
      ) ;_if assoc -3
    ) ;_progn
    (princ (strcat "\nНе хватает памяти для Рданных"
           "- Рданные не добавлены."
       ) ;_ End of strcat
    ) ;_ End of princ
  ) ;_if < xdsize
  ;; Наконец, обновить примитив с Рданными в базе данных.
  (entmod ELIST)
  (princ)
)
(defun RandNum (/ modulus multiplier increment random)
  (if (not *seed*)(setq *seed* (getvar "DATE")))
  (setq  modulus 65536 multiplier 25173 increment  13849
         *seed* (rem (+ (* multiplier *seed*) increment) modulus)
         random (/ *seed* modulus))
)
(defun _get_txt_dictxdName ()
(strcat "SumT" (substr (vl-string-translate "." "-" (rtos (getvar "CDATE") 2 9)) 3)(itoa (fix (* 100 (RandNum)))))
)
(defun _del_txt_dictxd ( en Rdn / elist sub)
   (setq elist (entget en (list "*")) sub nil)
   (foreach i (cdr (assoc -3 elist))
     (if (not(wcmatch (strcase(car i))(strcase Rdn)))
       (setq sub (append sub (list i)))
       (setq sub (append sub (list(list (car i)))))
       ))
  (setq sub (cons -3 sub)
        elist (subst sub (assoc -3 elist) elist)
        elist (entmod elist))
    )
;;;================================================================================
;;; Функция возвращает Расширенные Данные(РД) MIP_XD маркировки примитива
;;; в виде списка (METKA KOD) или NIL, если РД не присвоено
;;; (-3 ("MIP_XD" (1000 . METKA)(1070 . KOD)))
;;; METKA - метка примитива (строка)
;;; KOD   - код примитива (целое)
;;;         1 - Блок Знака ДО
;;;         2 -
;;;         3 -
;;;         4 -
(DEFUN _get_txt_dictxd (ENAME RNAME / XDLIST ELIST XD_ENT sps)
;;; Имя приложени
;;;  (setq RNAME "MIP_XD")
  (setq ELIST (entget ENAME (list RNAME)))
  (setq XD_ENT (cdr (assoc -3 ELIST)))    ; Старые Рданные.
  ;; Найти старые Рданные для того же приложени
  (if (setq XDLIST (assoc RNAME XD_ENT))
    (progn
      (setq XDLIST (cdr XDLIST))
      (foreach aa XDLIST
    (setq sps (append sps (list (cdr aa))))
      )    
    ) ;_ End of progn
 ;_Иначе возвращается NIL от if setq XDLIST
  ) ;_if
  sps
) ;_END defun _get_mark_xd
;;Создает связь между текстами автовычисления и приемником
(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* lst RDN)
  (defun *error* (msg)(princ msg)(Restorecolorlist)(princ))
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "SumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (if (null RDN)(setq RDN (_get_txt_dictxdName)))
              (setq 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(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))))
      (mapcar '(lambda (x)(_add_txt_dictxd x RDN "0")) lst)
       (mapcar 'SumT_ReactionUpd (reverse reac-list))
      )
    )
  (Restorecolorlist)
  (princ)
  )
(defun C:SumT_Restore ( / dst reac-list selset lst lst RDN)
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "SumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (setq dst (vlax-ename->vla-object dst))
             )
             )
           (setq reac-list (vl-remove-if-not '(lambda(reac)(member dst (vlr-owners reac)))(vlr-pers-list)))
           (if reac-list (princ "\nТекст зарегестрирован в цепочке суммирования"))
           (if (null RDN)(princ "\nТекст не помечен в цепочке суммирования"))
           (and (null reac-list) RDN))))
  (if (setq selset (ssget "_X" (list (cons 0  "*TEXT")
                                 (list -3 (list RDN)))))
    (progn
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
      (setq vla-list-owner (vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "0")) lst))
      (setq vla-dest (car(vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "1")) lst)))
      (if (and vla-list-owner vla-dest)
        (progn
          (mapcar '(lambda(x)(_del_txt_dictxd x Rdn)) lst)
          (add_sumt_object_reactor (mapcar 'vlax-ename->vla-object vla-list-owner)(vlax-ename->vla-object vla-dest))
          )
        (princ "\nНе найден текст-сумма или пуст список текстов-слагаемых")
        )
      )
    )
  (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_Restore - Восстановление цепочки"
"\nSumT_Viz - Визуализирует связь"
"\nSumT_VizR - Восстанавлиает предыдущее состояние"))
(princ)

Добавлена команда SumT_Restore - Восстановление цепочки
Во избежания проблем цепочки, созданные предыдущими версиями лиспа в этом обрабатываться не будут.

Re: Пересчет вычислений продолжение

Отлично!!!
А можна есчо сделать умножение??
И прогу можна кидать в готовые программы!!

Re: Пересчет вычислений продолжение

> Сергей
Тестируй с умножением
Во избежания проблем цепочки, созданные предыдущими версиями лиспа в этом обрабатываться не будут :(

;https://www.caduser.ru/forum/topic33835.html
;https://www.caduser.ru/forum/topic34287.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 MSumT-in-reac ( K vla-list-owner MSumT_Action / res selset ins_pt txt_height str)
(setq res 0.)
(if (= MSumT_Action "*")(setq MSumT_Action * res 1.0)(setq MSumT_Action + res 0.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 (MSumT_Action res (atof str))))))
(setq res (* K res))
;  (princ "\nРезультат=")(princ (rtos res 2))
res)
(defun add_MSumT_object_reactor ( vla-list-owner vla-dest MSumT_Action  / reac )
  (setq vla-list-owner (vl-remove vla-dest vla-list-owner))
  (setq reac (vlr-object-reactor vla-list-owner (list '("MSumTRname" "MSumT")
             (list "MSumTAction" MSumT_Action)(list "MSumTDEST" (vla-get-Handle vla-dest)))
    (list '(:vlr-modified . MSumT_Reaction) )))
  (vlr-pers reac)(_add-MSumT-RD vla-list-owner vla-dest MSumT_Action)
  (MSumT_ReactionUpd reac))
(defun MSumT_Reaction (vlao reac args / vla-dest ht dat en lst MSumT_Action)
  (vl-load-com)
  (if (vlr-added-p reac)(progn
  (setq dat (vlr-data reac))
   (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 MSumT_Action (cadr (assoc  "MSumTAction" dat)))
         (setq ht (MSumT-in-reac 1 lst MSumT_Action))
         (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)
  (cond ((= (type dat) 'INT)(setq dat (atoi dat)))
         ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))))
(defun MSumT_ReactionUpd (reac / vla-dest ht dat en lst MSumT_Action)
   (vl-load-com)
  (if (vlr-added-p reac)
   (progn
  (setq dat (vlr-data reac))
   (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 MSumT_Action (cadr (assoc  "MSumTAction" dat)))
         (setq ht (MSumT-in-reac 1 (vlr-owners reac) MSumT_Action))
         (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 MSumT_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 'MSumT_ReactionUpd (reverse reac-list))
  (_del-MSumT-RD  (vlax-vla-object->ename dst))
    )
(defun _del-MSumT-RD (e1)
  (mapcar '(lambda(x)(_del_txt_dictxd e1 x))
          (vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
            (mapcar 'car (car(lib:massoc -3 (entget e1 '("*")))))))
  (PurgeAPPID)
  )
(defun PurgeAPPID (/ appid)
  (vl-load-com)
  (vlax-for appid (vla-get-registeredapplications
            (vla-get-activedocument
              (vlax-get-acad-object)
            )
          )
    (vl-catch-all-apply 'vla-delete (list appid))
  )
  (princ)
)
(defun _add-MSumT-RD ( vla-list-owner vla-dest MSumT_Action / currRDName)
  (setq vla-list-owner (mapcar 'vlax-vla-object->ename vla-list-owner))
  (setq vla-dest (vlax-vla-object->ename vla-dest))
  (setq currRDName (vl-string-translate "*+" "MP"
                      (strcat (_get_txt_dictxdName) MSumT_Action)))
  (mapcar '(lambda(x)(_add_txt_dictxd x currRDName "0")) vla-list-owner)
  (_add_txt_dictxd vla-dest currRDName "1")
  )
(defun SetMSumTColor ( / 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 "MSumT_Color+"(mip-conv-to-str colP))
  (mip-reg-write "MSumT_Color="(mip-conv-to-str colS))
  )
  (defun GetMSumTColor ( / ht )(list
  (if (setq ht (mip-reg-read "MSumT_Color+")) ht "1")
  (if (setq ht (mip-reg-read "MSumT_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 *MSumT-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 *MSumT-obj-list*  nil)
 (princ " ok")(princ)
)
(defun MSumT_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 obj (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 "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 (GetMSumTColor))
    colS (cadr colP)
    colP (car colP)
    )
  (setq *MSumT-obj-list* (append *MSumT-obj-list* (mapcar 'getcolorlist owner-list))
        *MSumT-obj-list* (append *MSumT-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Команда MSumT_VizR восстановит цвет текста ")
  (princ)
  )
(defun lib:massoc (key alist)
 (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
;;;================================================================================
;;; Функция добавляет Расширенные Данные к примитиву
;;; ENAME - Имя примитива
;;; RNAME - имя приложения
;;; DICT - имя словаря примитива (строка)
;;; (-3 ("MIP_XD" (1000 . DICT)(1005.METKA)))
(DEFUN _add_txt_dictxd
       (ENAME RNAME DICT  / XDLIST ELIST METKA XD_ENT XD_LIST3)
  (regapp RNAME)
  (setq ELIST (entget ENAME '("*")))
  (setq METKA (cdr (assoc 5 ELIST)))
  (setq XDLIST (list (cons 1000 DICT)(cons 1005 METKA)))
  (setq XDLIST (list (cons RNAME XDLIST)))
  (setq XDLIST (cons -3 XDLIST))
  (if (< (xdsize XDLIST) (xdroom ENAME)); Если есть еще пространство...
    (progn
      (if (assoc -3 ELIST)        ; и уже есть Рданные...
    (progn
      (setq XDLIST (cdr XDLIST))    ; Новые Рданные.
      (setq XD_ENT (cdr (assoc -3 ELIST))) ; Старые Рданные.
      ;; Найти старые Рданные для того же приложени
      (if (assoc RNAME XD_ENT)
        (progn
          ;; Поместить обратно в существующий список Рданных
          (setq XD_LIST3 (subst (car XDLIST)
                    (assoc RNAME XD_ENT)
                    (assoc -3 ELIST)
                 ) ;_ End of subst
          ) ;_ End of setq
        ) ;_ End of progn
        (progn            ; Это новое приложение...
          (setq XDLIST (append XD_ENT XDLIST))
                    ; Объединить Рданные.
          (setq XD_LIST3 (cons -3 XDLIST))
        ) ;_ End of progn
      ) ;_if assoc RNAME
      (setq ELIST (subst XD_LIST3 (assoc -3 ELIST) ELIST))
                    ; Объединить с примитивом
    ) ;_progn
    (setq ELIST (cons XDLIST ELIST)) ; Пока нет Рданных.
      ) ;_if assoc -3
    ) ;_progn
    (princ (strcat "\nНе хватает памяти для Рданных"
           "- Рданные не добавлены."
       ) ;_ End of strcat
    ) ;_ End of princ
  ) ;_if < xdsize
  ;; Наконец, обновить примитив с Рданными в базе данных.
  (entmod ELIST)
  (princ)
)
(defun RandNum (/ modulus multiplier increment random)
  (if (not *seed*)(setq *seed* (getvar "DATE")))
  (setq  modulus 65536 multiplier 25173 increment  13849
         *seed* (rem (+ (* multiplier *seed*) increment) modulus)
         random (/ *seed* modulus))
)
(defun _get_txt_dictxdName ()
(strcat "MSumT" (substr (vl-string-translate "." "-" (rtos (getvar "CDATE") 2 9)) 3)(itoa (fix (* 100 (RandNum)))))
)
(defun _del_txt_dictxd ( en Rdn / elist sub)
   (setq elist (entget en (list "*")) sub nil)
   (foreach i (cdr (assoc -3 elist))
     (if (not(wcmatch (strcase(car i))(strcase Rdn)))
       (setq sub (append sub (list i)))
       (setq sub (append sub (list(list (car i)))))
       ))
  (setq sub (cons -3 sub)
        elist (subst sub (assoc -3 elist) elist)
        elist (entmod elist))
    )
;;;================================================================================
;;; Функция возвращает Расширенные Данные(РД)  примитива
;;; в виде списка (METKA KOD) или NIL, если РД не присвоено
(DEFUN _get_txt_dictxd (ENAME RNAME / XDLIST ELIST XD_ENT sps)
  (setq ELIST (entget ENAME (list RNAME)))
  (setq XD_ENT (cdr (assoc -3 ELIST)))    ; Старые Рданные.
  ;; Найти старые Рданные для того же приложени
  (if (setq XDLIST (assoc RNAME XD_ENT))
    (progn
      (setq XDLIST (cdr XDLIST))
      (foreach aa XDLIST
    (setq sps (append sps (list (cdr aa))))
      )    
    ) ;_ End of progn
  ) ;_if
  sps
) ;_END defun _get_mark_xd
(defun _get-MSumT_Action ( RDN / MSumT_Action)
 (setq MSumT_Action  (vl-list->string (list(last (vl-string->list RDN)))))
 (if (=  MSumT_Action "M")(setq MSumT_Action "*")(setq MSumT_Action "+"))
  )
(defun C:MSumT_Creat ( / MSumT_Action)
  (initget "Multiplication Sum Умножение Сумма _* + * +")
  (if (null(setq MSumT_Action(getkword "\nУкажите действие цепочки [Умножение/Сумма] <Сумма>:")))
    (setq MSumT_Action "+")
    )
  (MSumT_Creat MSumT_Action)
  (princ)
)
;;Создает связь между текстами автовычисления и приемником
(defun MSumT_Creat ( MSumT_Action / 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_MSumT_object_reactor (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
     dst MSumT_Action)
    )
  (princ)
  )
;_Добавляет текст к существующей цепочке автосуммы
(defun C:MSumT_Add ( / dst reac-list selset lst *error* lst RDN)
  (defun *error* (msg)(princ msg)(Restorecolorlist)(princ))
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (if (null RDN)(setq RDN (_get_txt_dictxdName)))
              (setq 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 'MSumT_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(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))))
      (mapcar '(lambda (x)(_add_txt_dictxd x RDN "0")) lst)
       (mapcar 'MSumT_ReactionUpd (reverse reac-list))
      )
    )
  (Restorecolorlist)
  (PurgeAPPID)
  (princ)
  )
(defun C:MSumT_Restore ( / dst reac-list selset lst lst RDN MSumT_Action)
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (setq dst (vlax-ename->vla-object dst))
             )
             )
           (setq reac-list (vl-remove-if-not '(lambda(reac)(member dst (vlr-owners reac)))(vlr-pers-list)))
           (if reac-list (princ "\nТекст зарегестрирован в цепочке суммирования"))
           (if (null RDN)(princ "\nТекст не помечен в цепочке суммирования"))
           (and (null reac-list) RDN))))
  (if (setq selset (ssget "_X" (list (cons 0  "*TEXT")
                                 (list -3 (list RDN)))))
    (progn
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
      (setq vla-list-owner (vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "0")) lst))
      (setq vla-dest (car(vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "1")) lst)))
      (if (and vla-list-owner vla-dest)
        (progn
          (setq MSumT_Action (_get-MSumT_Action RDN))
          (mapcar '(lambda(x)(_del_txt_dictxd x Rdn)) lst)
          (add_MSumT_object_reactor (mapcar 'vlax-ename->vla-object vla-list-owner)(vlax-ename->vla-object vla-dest) MSumT_Action)
          )
        (princ "\nНе найден текст-сумма или пуст список текстов-слагаемых")
        )
      )
    )
  (PurgeAPPID)
  (princ)
  )
;;Удаляет текст из связи
(defun C:MSumT_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)
    )
  (MSumT_del dst)
    )
    )
  (princ)
  )
;;Удаляет тексты из связи
(defun C:MSumT_Del ( / dst )
  (vl-load-com)
  (princ "\nУкажите тексты для удаления из цепочки")
  (if (setq  dst (ssget "_:L" '((0 . "*TEXT"))))
    (progn
  (mapcar 'MSumT_del (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex dst)))))
    )
    )
  (princ)
  )
;;;Задание цвета цепочке и сумме
(defun C:MSumT_Color ()(SetMSumTColor)(princ))
;;Визуализирует связь
(defun C:MSumT_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)
    )
  (MSumT_Viz dst)
  )
    )
  (princ)
  )
;;Восстанавлиает предыдущее состояние
(defun C:MSumT_VizR ( )(Restorecolorlist))
(mapcar 'princ (list
"\n ====  Определенные команды  ===="
"\nMSumT_Creat - Создает связь между текстами (сумма и умножение)"
"\nMSumT_Add - Добавляет текст к существующей цепочке автосуммы"
"\nMSumT_Del1 - Удаляет текст из связи"
"\nMSumT_Del - Удаляет тексты из связи"
"\nMSumT_Color - Задание цвета цепочке и сумме"
"\nMSumT_Restore - Восстановление цепочки"
"\nMSumT_Viz - Визуализирует связь"
"\nMSumT_VizR - Восстанавлиает предыдущее состояние"))
(princ)
;|============= Команда MSumT ==================================
Назначение: Суммирование Тектса,Мтекста указанием или рамкой.
Особенности: Безразлична к разделителям точка или запятая.
Ввиду особенности работы atof стоки вида "22.3мама"
будут учтены как число 22.3
При выводе результата число округляется в соответствии
с текущими установками переменной LUPREC. Команда _UNITS
|;
(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 MSumT ( K / res selset ins_pt txt_height str)
(vl-load-com)(setq res 0.)
(if (setq selset (ssget '((0 . "TEXT,MTEXT"))))
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
(setq str (mip_mtext_unformat (vla-get-textstring (vlax-ename->vla-object ent)))
str (vl-string-translate "," "." (vl-string-trim "%UuoOcC \t" str))
str (vl-string-trim "%UuoOcC \t" str) res (+ res (atof str))))) ;_ end of if
(setq res (* K res))(princ "\nРезультат=")(princ (rtos res 2))
(if (not (equal res 0. 1e-3))
(progn
(if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0) ;_ end of =
(progn ;; нулевая высота текста
(if (not (setq txt_height (getreal "\nВведите высоту текста <2.5> : ")))(setq txt_height 2.5))
(vl-cmdf "_.TEXT" "0,0" txt_height 0 (rtos res 2))) ;_ end of progn
(progn ;; фиксированнная высота
(vl-cmdf "_.TEXT" "0,0" 0 txt (rtos res 2))) ;_ end of progn
)
(command "_.copybase" "0,0" (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)
) ;_ end of progn
) ;_ end of if
res)
(defun C:MSumT ( )(MSumT 1)(princ))
(defun C:MSumT2 ( )(MSumT 2)(princ))
(princ "\nНаберите в командной строке MSumT MSumT2")
(defun lib:massoc (key alist)
 (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
;;;================================================================================
;;; Функция добавляет Расширенные Данные к примитиву
;;; (-3 ("MIP_XD" (1000 . DICT)(1005.METKA)))
;;; DICT - имя словаря примитива (строка)
;;; ELIST - Полный список {(setq ELIST (entget ENAME (list "MIP_XD")))}
;;; ENAME - Имя примитива
;;; RNAME - имя приложения
(DEFUN _add_txt_dictxd
       (ENAME RNAME DICT  / XDLIST ELIST METKA XD_ENT XD_LIST3)
;;; Имя приложени
  (regapp RNAME)
  (setq ELIST (entget ENAME '("*")))
  (setq METKA (cdr (assoc 5 ELIST)))
;;; ======== Сформировать список РАСШИРЕННЫХ ДАННЫХ
  (setq XDLIST (list (cons 1000 DICT)(cons 1005 METKA)))
;;; Добавить имя приложения в начало списка Рданных.
  (setq XDLIST (list (cons RNAME XDLIST)))
;;; Добавить код группы -3 перед списком расширенных данных.
  (setq XDLIST (cons -3 XDLIST))
;;;(princ "\nXDLIST=")(princ XDLIST)
  ;; Теперь список расширенных данных добавлен к данным примитива. Сложнее,
  ;; если примитив уже имеет Рданные. Следует также проверить достаточность
  ;; пространства для Рданных.
  (if (< (xdsize XDLIST) (xdroom ENAME)); Если есть еще пространство...
    (progn
      (if (assoc -3 ELIST)        ; и уже есть Рданные...
    (progn
      (setq XDLIST (cdr XDLIST))    ; Новые Рданные.
      (setq XD_ENT (cdr (assoc -3 ELIST))) ; Старые Рданные.
      ;; Найти старые Рданные для того же приложени
      (if (assoc RNAME XD_ENT)
        (progn
          ;; Поместить обратно в существующий список Рданных
          (setq XD_LIST3 (subst (car XDLIST)
                    (assoc RNAME XD_ENT)
                    (assoc -3 ELIST)
                 ) ;_ End of subst
          ) ;_ End of setq
        ) ;_ End of progn
        (progn            ; Это новое приложение...
          (setq XDLIST (append XD_ENT XDLIST))
                    ; Объединить Рданные.
          (setq XD_LIST3 (cons -3 XDLIST))
        ) ;_ End of progn
      ) ;_if assoc RNAME
      (setq ELIST (subst XD_LIST3 (assoc -3 ELIST) ELIST))
                    ; Объединить с примитивом
    ) ;_progn
    (setq ELIST (cons XDLIST ELIST)) ; Пока нет Рданных.
      ) ;_if assoc -3
    ) ;_progn
    (princ (strcat "\nНе хватает памяти для Рданных"
           "- Рданные не добавлены."
       ) ;_ End of strcat
    ) ;_ End of princ
  ) ;_if < xdsize
  ;; Наконец, обновить примитив с Рданными в базе данных.
  (entmod ELIST)
  (princ)
)
(defun RandNum (/ modulus multiplier increment random)
  (if (not *seed*)(setq *seed* (getvar "DATE")))
  (setq  modulus 65536 multiplier 25173 increment  13849
         *seed* (rem (+ (* multiplier *seed*) increment) modulus)
         random (/ *seed* modulus))
)
(defun _get_txt_dictxdName ()
(strcat "MSumT" (substr (vl-string-translate "." "-" (rtos (getvar "CDATE") 2 9)) 3)(itoa (fix (* 100 (RandNum)))))
)
(defun _del_txt_dictxd ( en Rdn / elist sub)
   (setq elist (entget en (list "*")) sub nil)
   (foreach i (cdr (assoc -3 elist))
     (if (not(wcmatch (strcase(car i))(strcase Rdn)))
       (setq sub (append sub (list i)))
       (setq sub (append sub (list(list (car i)))))
       ))
  (setq sub (cons -3 sub)
        elist (subst sub (assoc -3 elist) elist)
        elist (entmod elist))
    )
;;;================================================================================
;;; Функция возвращает Расширенные Данные(РД) MIP_XD маркировки примитива
;;; в виде списка (METKA KOD) или NIL, если РД не присвоено
;;; (-3 ("MIP_XD" (1000 . METKA)(1070 . KOD)))
;;; METKA - метка примитива (строка)
;;; KOD   - код примитива (целое)
;;;         1 - Блок Знака ДО
;;;         2 -
;;;         3 -
;;;         4 -
(DEFUN _get_txt_dictxd (ENAME RNAME / XDLIST ELIST XD_ENT sps)
;;; Имя приложени
;;;  (setq RNAME "MIP_XD")
  (setq ELIST (entget ENAME (list RNAME)))
  (setq XD_ENT (cdr (assoc -3 ELIST)))    ; Старые Рданные.
  ;; Найти старые Рданные для того же приложени
  (if (setq XDLIST (assoc RNAME XD_ENT))
    (progn
      (setq XDLIST (cdr XDLIST))
      (foreach aa XDLIST
    (setq sps (append sps (list (cdr aa))))
      )    
    ) ;_ End of progn
 ;_Иначе возвращается NIL от if setq XDLIST
  ) ;_if
  sps
) ;_END defun _get_mark_xd
;(ssget "_X" '((0 . "*TEXT")(-3 ("MSumT12"))))
(defun getUniqSumRegName (pat / sset i grpName)
  (setq i 0)
  (while (and (setq grpName (strcat pat (itoa (setq i (1+ i)))))
          (setq sset (ssget "_X" (list '(0 . "*TEXT")(list -3 (list grpName))))))
          (setq sset nil))
  (gc)
  grpName
  )
(defun getUniqSumGroupName (pat / grpList i grpName)
  (setq grpList (mapcar 'strcase (massoc 3 (dictsearch (namedobjdict) "ACAD_GROUP")))
    i 0
    pat (strcase (VL-PRINC-TO-STRING pat))
    )
  (while (member (setq grpName (strcat pat (itoa (setq i (1+ i))))) grpList))
  grpName
  )
(defun massoc (key alist)
(mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist))) ;_ end of defun
; Ф-ция GetObjGroupNames
; Возвращает список имен групп объекта или nil.
; Arguments [Type]:
;   Obj = Object [VLA-OBJECT]
;   Obj = Object [ENAME]
; Возвращает [Type]:
;   Список имен групп [list]
;
(defun GetObjGroupNames (Obj / Cur_ID NmeLst)
 (or *kpblc-activedoc*
   (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
)
 (if (= (type Obj) 'ENAME)(setq Obj (vlax-ename->vla-object Obj)))
 (setq Cur_ID (vla-get-ObjectID Obj))
 (vlax-for Grp (vla-get-Groups *kpblc-activedoc*)
  (vlax-for Ent Grp
   (if (equal (vla-get-ObjectID Ent) Cur_ID)
    (setq NmeLst (cons (vla-get-Name Grp) NmeLst))
   )
   (vlax-release-object Ent)
  )
  (vlax-release-object Grp)
 )
 (reverse NmeLst)
)

Re: Пересчет вычислений продолжение

> Модератору
Удалите предыдущий пост
>Сергей (20 …  10:30:24)

Заново. В предыдущем посте много лишнего захватил. Тестируй с умножением отсюда.
Во избежания проблем цепочки, созданные предыдущими версиями лиспа в этом обрабатываться не будут :(

;https://www.caduser.ru/forum/topic33835.html
;https://www.caduser.ru/forum/topic34287.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 MSumT-in-reac ( K vla-list-owner MSumT_Action / res selset ins_pt txt_height str)
(setq res 0.)
(if (= MSumT_Action "*")(setq MSumT_Action * res 1.0)(setq MSumT_Action + res 0.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 (MSumT_Action res (atof str))))))
(setq res (* K res))
;  (princ "\nРезультат=")(princ (rtos res 2))
res)
(defun add_MSumT_object_reactor ( vla-list-owner vla-dest MSumT_Action  / reac )
  (setq vla-list-owner (vl-remove vla-dest vla-list-owner))
  (setq reac (vlr-object-reactor vla-list-owner (list '("MSumTRname" "MSumT")
             (list "MSumTAction" MSumT_Action)(list "MSumTDEST" (vla-get-Handle vla-dest)))
    (list '(:vlr-modified . MSumT_Reaction) )))
  (vlr-pers reac)(_add-MSumT-RD vla-list-owner vla-dest MSumT_Action)
  (MSumT_ReactionUpd reac))
(defun MSumT_Reaction (vlao reac args / vla-dest ht dat en lst MSumT_Action)
  (vl-load-com)
  (if (vlr-added-p reac)(progn
  (setq dat (vlr-data reac))
   (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 MSumT_Action (cadr (assoc  "MSumTAction" dat)))
         (setq ht (MSumT-in-reac 1 lst MSumT_Action))
         (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)
  (cond ((= (type dat) 'INT)(setq dat (atoi dat)))
         ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))))
(defun MSumT_ReactionUpd (reac / vla-dest ht dat en lst MSumT_Action)
   (vl-load-com)
  (if (vlr-added-p reac)
   (progn
  (setq dat (vlr-data reac))
   (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 MSumT_Action (cadr (assoc  "MSumTAction" dat)))
         (setq ht (MSumT-in-reac 1 (vlr-owners reac) MSumT_Action))
         (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 MSumT_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 'MSumT_ReactionUpd (reverse reac-list))
  (_del-MSumT-RD  (vlax-vla-object->ename dst))
    )
(defun _del-MSumT-RD (e1)
  (mapcar '(lambda(x)(_del_txt_dictxd e1 x))
          (vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
            (mapcar 'car (car(lib:massoc -3 (entget e1 '("*")))))))
  (PurgeAPPID)
  )
(defun PurgeAPPID (/ appid)
  (vl-load-com)
  (vlax-for appid (vla-get-registeredapplications
            (vla-get-activedocument
              (vlax-get-acad-object)
            )
          )
    (vl-catch-all-apply 'vla-delete (list appid))
  )
  (princ)
)
(defun _add-MSumT-RD ( vla-list-owner vla-dest MSumT_Action / currRDName)
  (setq vla-list-owner (mapcar 'vlax-vla-object->ename vla-list-owner))
  (setq vla-dest (vlax-vla-object->ename vla-dest))
  (setq currRDName (vl-string-translate "*+" "MP"
                      (strcat (_get_txt_dictxdName) MSumT_Action)))
  (mapcar '(lambda(x)(_add_txt_dictxd x currRDName "0")) vla-list-owner)
  (_add_txt_dictxd vla-dest currRDName "1")
  )
(defun SetMSumTColor ( / 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 "MSumT_Color+"(mip-conv-to-str colP))
  (mip-reg-write "MSumT_Color="(mip-conv-to-str colS))
  )
  (defun GetMSumTColor ( / ht )(list
  (if (setq ht (mip-reg-read "MSumT_Color+")) ht "1")
  (if (setq ht (mip-reg-read "MSumT_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 *MSumT-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 *MSumT-obj-list*  nil)
 (princ " ok")(princ)
)
(defun MSumT_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 obj (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 "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 (GetMSumTColor))
    colS (cadr colP)
    colP (car colP)
    )
  (setq *MSumT-obj-list* (append *MSumT-obj-list* (mapcar 'getcolorlist owner-list))
        *MSumT-obj-list* (append *MSumT-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Команда MSumT_VizR восстановит цвет текста ")
  (princ)
  )
(defun lib:massoc (key alist)
 (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
;;;================================================================================
;;; Функция добавляет Расширенные Данные к примитиву
;;; ENAME - Имя примитива
;;; RNAME - имя приложения
;;; DICT - имя словаря примитива (строка)
;;; (-3 ("MIP_XD" (1000 . DICT)(1005.METKA)))
(DEFUN _add_txt_dictxd
       (ENAME RNAME DICT  / XDLIST ELIST METKA XD_ENT XD_LIST3)
  (regapp RNAME)
  (setq ELIST (entget ENAME '("*")))
  (setq METKA (cdr (assoc 5 ELIST)))
  (setq XDLIST (list (cons 1000 DICT)(cons 1005 METKA)))
  (setq XDLIST (list (cons RNAME XDLIST)))
  (setq XDLIST (cons -3 XDLIST))
  (if (< (xdsize XDLIST) (xdroom ENAME)); Если есть еще пространство...
    (progn
      (if (assoc -3 ELIST)        ; и уже есть Рданные...
    (progn
      (setq XDLIST (cdr XDLIST))    ; Новые Рданные.
      (setq XD_ENT (cdr (assoc -3 ELIST))) ; Старые Рданные.
      ;; Найти старые Рданные для того же приложени
      (if (assoc RNAME XD_ENT)
        (progn
          ;; Поместить обратно в существующий список Рданных
          (setq XD_LIST3 (subst (car XDLIST)
                    (assoc RNAME XD_ENT)
                    (assoc -3 ELIST)
                 ) ;_ End of subst
          ) ;_ End of setq
        ) ;_ End of progn
        (progn            ; Это новое приложение...
          (setq XDLIST (append XD_ENT XDLIST))
                    ; Объединить Рданные.
          (setq XD_LIST3 (cons -3 XDLIST))
        ) ;_ End of progn
      ) ;_if assoc RNAME
      (setq ELIST (subst XD_LIST3 (assoc -3 ELIST) ELIST))
                    ; Объединить с примитивом
    ) ;_progn
    (setq ELIST (cons XDLIST ELIST)) ; Пока нет Рданных.
      ) ;_if assoc -3
    ) ;_progn
    (princ (strcat "\nНе хватает памяти для Рданных"
           "- Рданные не добавлены."
       ) ;_ End of strcat
    ) ;_ End of princ
  ) ;_if < xdsize
  ;; Наконец, обновить примитив с Рданными в базе данных.
  (entmod ELIST)
  (princ)
)
(defun RandNum (/ modulus multiplier increment random)
  (if (not *seed*)(setq *seed* (getvar "DATE")))
  (setq  modulus 65536 multiplier 25173 increment  13849
         *seed* (rem (+ (* multiplier *seed*) increment) modulus)
         random (/ *seed* modulus))
)
(defun _get_txt_dictxdName ()
(strcat "MSumT" (substr (vl-string-translate "." "-" (rtos (getvar "CDATE") 2 9)) 3)(itoa (fix (* 100 (RandNum)))))
)
(defun _del_txt_dictxd ( en Rdn / elist sub)
   (setq elist (entget en (list "*")) sub nil)
   (foreach i (cdr (assoc -3 elist))
     (if (not(wcmatch (strcase(car i))(strcase Rdn)))
       (setq sub (append sub (list i)))
       (setq sub (append sub (list(list (car i)))))
       ))
  (setq sub (cons -3 sub)
        elist (subst sub (assoc -3 elist) elist)
        elist (entmod elist))
    )
;;;================================================================================
;;; Функция возвращает Расширенные Данные(РД)  примитива
;;; в виде списка (METKA KOD) или NIL, если РД не присвоено
(DEFUN _get_txt_dictxd (ENAME RNAME / XDLIST ELIST XD_ENT sps)
  (setq ELIST (entget ENAME (list RNAME)))
  (setq XD_ENT (cdr (assoc -3 ELIST)))    ; Старые Рданные.
  ;; Найти старые Рданные для того же приложени
  (if (setq XDLIST (assoc RNAME XD_ENT))
    (progn
      (setq XDLIST (cdr XDLIST))
      (foreach aa XDLIST
    (setq sps (append sps (list (cdr aa))))
      )    
    ) ;_ End of progn
  ) ;_if
  sps
) ;_END defun _get_mark_xd
(defun _get-MSumT_Action ( RDN / MSumT_Action)
 (setq MSumT_Action  (vl-list->string (list(last (vl-string->list RDN)))))
 (if (=  MSumT_Action "M")(setq MSumT_Action "*")(setq MSumT_Action "+"))
  )
(defun C:MSumT_Creat ( / MSumT_Action)
  (initget "Multiplication Sum Умножение Сумма _* + * +")
  (if (null(setq MSumT_Action(getkword "\nУкажите действие цепочки [Умножение/Сумма] <Сумма>:")))
    (setq MSumT_Action "+")
    )
  (MSumT_Creat MSumT_Action)
  (princ)
)
;;Создает связь между текстами автовычисления и приемником
(defun MSumT_Creat ( MSumT_Action / 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_MSumT_object_reactor (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
     dst MSumT_Action)
    )
  (princ)
  )
;_Добавляет текст к существующей цепочке автосуммы
(defun C:MSumT_Add ( / dst reac-list selset lst *error* lst RDN)
  (defun *error* (msg)(princ msg)(Restorecolorlist)(princ))
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (if (null RDN)(setq RDN (_get_txt_dictxdName)))
              (setq 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 'MSumT_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(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))))
      (mapcar '(lambda (x)(_add_txt_dictxd x RDN "0")) lst)
       (mapcar 'MSumT_ReactionUpd (reverse reac-list))
      )
    )
  (Restorecolorlist)
  (PurgeAPPID)
  (princ)
  )
(defun C:MSumT_Restore ( / dst reac-list selset lst lst RDN MSumT_Action)
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (setq dst (vlax-ename->vla-object dst))
             )
             )
           (setq reac-list (vl-remove-if-not '(lambda(reac)(member dst (vlr-owners reac)))(vlr-pers-list)))
           (if reac-list (princ "\nТекст зарегестрирован в цепочке суммирования"))
           (if (null RDN)(princ "\nТекст не помечен в цепочке суммирования"))
           (and (null reac-list) RDN))))
  (if (setq selset (ssget "_X" (list (cons 0  "*TEXT")
                                 (list -3 (list RDN)))))
    (progn
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
      (setq vla-list-owner (vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "0")) lst))
      (setq vla-dest (car(vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "1")) lst)))
      (if (and vla-list-owner vla-dest)
        (progn
          (setq MSumT_Action (_get-MSumT_Action RDN))
          (mapcar '(lambda(x)(_del_txt_dictxd x Rdn)) lst)
          (add_MSumT_object_reactor (mapcar 'vlax-ename->vla-object vla-list-owner)(vlax-ename->vla-object vla-dest) MSumT_Action)
          )
        (princ "\nНе найден текст-сумма или пуст список текстов-слагаемых")
        )
      )
    )
  (PurgeAPPID)
  (princ)
  )
;;Удаляет текст из связи
(defun C:MSumT_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)
    )
  (MSumT_del dst)
    )
    )
  (princ)
  )
;;Удаляет тексты из связи
(defun C:MSumT_Del ( / dst )
  (vl-load-com)
  (princ "\nУкажите тексты для удаления из цепочки")
  (if (setq  dst (ssget "_:L" '((0 . "*TEXT"))))
    (progn
  (mapcar 'MSumT_del (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex dst)))))
    )
    )
  (princ)
  )
;;;Задание цвета цепочке и сумме
(defun C:MSumT_Color ()(SetMSumTColor)(princ))
;;Визуализирует связь
(defun C:MSumT_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)
    )
  (MSumT_Viz dst)
  )
    )
  (princ)
  )
;;Восстанавлиает предыдущее состояние
(defun C:MSumT_VizR ( )(Restorecolorlist))
(mapcar 'princ (list
"\n ====  Определенные команды  ===="
"\nMSumT_Creat - Создает связь между текстами (сумма и умножение)"
"\nMSumT_Add - Добавляет текст к существующей цепочке автосуммы"
"\nMSumT_Del1 - Удаляет текст из связи"
"\nMSumT_Del - Удаляет тексты из связи"
"\nMSumT_Color - Задание цвета цепочке и сумме"
"\nMSumT_Restore - Восстановление цепочки"
"\nMSumT_Viz - Визуализирует связь"
"\nMSumT_VizR - Восстанавлиает предыдущее состояние"))
(princ)

Re: Пересчет вычислений продолжение

Не работает команда "MSumT_Color", пишет
bad argument type: stringp 2
И при выборе суммы или умножения можна сделать оконный выбор, а не вписывать в командную строку "у"!
Типа при команде "MSumT_Creat" открывается окошко с выбором сумма или умножить тыкнул мышкой и напрягатся не нужно какую букву и на какой раскладке вписывать!! Чисто для удобства!

Re: Пересчет вычислений продолжение

> Сергей

;https://www.caduser.ru/forum/topic33835.html
;https://www.caduser.ru/forum/topic34287.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 MSumT-in-reac ( K vla-list-owner MSumT_Action / res selset ins_pt txt_height str)
(setq res 0.)
(if (= MSumT_Action "*")(setq MSumT_Action * res 1.0)(setq MSumT_Action + res 0.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 (MSumT_Action res (atof str))))))
(setq res (* K res))
;  (princ "\nРезультат=")(princ (rtos res 2))
res)
(defun add_MSumT_object_reactor ( vla-list-owner vla-dest MSumT_Action  / reac RDN)
  (setq vla-list-owner (vl-remove vla-dest vla-list-owner))
  (setq RDN (_add-MSumT-RD vla-list-owner vla-dest MSumT_Action))
  (setq reac (vlr-object-reactor vla-list-owner (list '("MSumTRname" "MSumT")
        (list "MSumTAction" MSumT_Action)(list "MSumTDEST" (vla-get-Handle vla-dest))
        (list "MSumTRDN" RDN))(list '(:vlr-modified . MSumT_Reaction))))
  (vlr-pers reac)(MSumT_ReactionUpd reac))
(defun MSumT_Reaction (vlao reac args / vla-dest ht dat en lst MSumT_Action)
  (vl-load-com)
  (if (vlr-added-p reac)(progn
  (setq dat (vlr-data reac))
   (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 MSumT_Action (cadr (assoc  "MSumTAction" dat)))
         (setq ht (MSumT-in-reac 1 lst MSumT_Action))
         (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)
  (cond ((= (type dat) 'INT)(setq dat (itoa dat)))
         ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))))
(defun mydcl (zagl info-list / fl ret dcl_id)
(vl-load-com)(if (null zagl)(setq zagl "Выбор")) ;_ end of if
(setq fl (vl-filename-mktemp "mip" nil ".dcl"))
(setq ret (open fl "w"))
(mapcar '(lambda (x) (write-line x ret))
(list "mip_msg : dialog { " (strcat "label=\"" zagl "\";")
" :list_box {" "alignment=top ;" "width=51 ;"
(if (> (length info-list) 26) "height= 26 ;"
(strcat "height= " (itoa (+ 3 (length info-list))) ";"))
"is_tab_stop = false ;" "key = \"info\";}" "ok_cancel;}"))
(setq ret (close ret))(if (setq dcl_id (load_dialog fl))
(if (new_dialog "mip_msg" dcl_id)(progn (start_list "info")
(mapcar 'add_list info-list)(end_list)(set_tile "info" "0")
(setq ret (car info-list))(action_tile "info" "(setq ret (nth (atoi $value) info-list))")
(action_tile "cancel" "(progn(setq ret nil)(done_dialog 0))")
(action_tile "accept" "(done_dialog 1)")(start_dialog))))
(unload_dialog dcl_id)(vl-file-delete fl) ret)
(defun MSumT_ReactionUpd (reac / vla-dest ht dat en lst MSumT_Action)
   (vl-load-com)
  (if (vlr-added-p reac)
   (progn
  (setq dat (vlr-data reac))
   (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 MSumT_Action (cadr (assoc  "MSumTAction" dat)))
         (setq ht (MSumT-in-reac 1 (vlr-owners reac) MSumT_Action))
         (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 MSumT_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 'MSumT_ReactionUpd (reverse reac-list))
  (_del-MSumT-RD  (vlax-vla-object->ename dst))
    )
(defun _del-MSumT-RD (e1)
  (mapcar '(lambda(x)(_del_txt_dictxd e1 x))
          (vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
            (mapcar 'car (car(lib:massoc -3 (entget e1 '("*")))))))
  (PurgeAPPID)
  )
(defun PurgeAPPID (/ appid)
  (vl-load-com)
  (vlax-for appid (vla-get-registeredapplications
            (vla-get-activedocument
              (vlax-get-acad-object)
            )
          )
    (vl-catch-all-apply 'vla-delete (list appid))
  )
  (princ)
)
(defun _add-MSumT-RD ( vla-list-owner vla-dest MSumT_Action / currRDName)
  (setq vla-list-owner (mapcar 'vlax-vla-object->ename vla-list-owner))
  (setq vla-dest (vlax-vla-object->ename vla-dest))
  (setq currRDName (vl-string-translate "*+" "MP"
                      (strcat (_get_txt_dictxdName) MSumT_Action)))
  (mapcar '(lambda(x)(_add_txt_dictxd x currRDName "0")) vla-list-owner)
  (_add_txt_dictxd vla-dest currRDName "1")
  currRDName
  )
(defun SetMSumTColor ( / 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 "MSumT_Color+"(mip-conv-to-str colP))
  (mip-reg-write "MSumT_Color="(mip-conv-to-str colS))
  )
  (defun GetMSumTColor ( / ht )(list
  (if (setq ht (mip-reg-read "MSumT_Color+")) ht "1")
  (if (setq ht (mip-reg-read "MSumT_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 *MSumT-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 *MSumT-obj-list*  nil)
 (princ " ok")(princ)
)
(defun MSumT_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 obj (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 "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 (GetMSumTColor))
    colS (cadr colP)  colP (car colP))
  (setq *MSumT-obj-list* (append *MSumT-obj-list* (mapcar 'getcolorlist owner-list))
        *MSumT-obj-list* (append *MSumT-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Команда MSumT_VizR восстановит цвет текста ")(princ))
(defun lib:massoc (key alist)
 (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
;;;================================================================================
;;; Функция добавляет Расширенные Данные к примитиву
;;; ENAME - Имя примитива
;;; RNAME - имя приложения
;;; DICT - имя словаря примитива (строка)
;;; (-3 ("MIP_XD" (1000 . DICT)(1005.METKA)))
(DEFUN _add_txt_dictxd
       (ENAME RNAME DICT  / XDLIST ELIST METKA XD_ENT XD_LIST3)
  (regapp RNAME)
  (setq ELIST (entget ENAME '("*")))
  (setq METKA (cdr (assoc 5 ELIST)))
  (setq XDLIST (list (cons 1000 DICT)(cons 1005 METKA)))
  (setq XDLIST (list (cons RNAME XDLIST)))
  (setq XDLIST (cons -3 XDLIST))
  (if (< (xdsize XDLIST) (xdroom ENAME)); Если есть еще пространство...
    (progn
      (if (assoc -3 ELIST)        ; и уже есть Рданные...
    (progn
      (setq XDLIST (cdr XDLIST))    ; Новые Рданные.
      (setq XD_ENT (cdr (assoc -3 ELIST))) ; Старые Рданные.
      ;; Найти старые Рданные для того же приложени
      (if (assoc RNAME XD_ENT)
        (progn
          ;; Поместить обратно в существующий список Рданных
          (setq XD_LIST3 (subst (car XDLIST)
                    (assoc RNAME XD_ENT)
                    (assoc -3 ELIST)
                 ) ;_ End of subst
          ) ;_ End of setq
        ) ;_ End of progn
        (progn            ; Это новое приложение...
          (setq XDLIST (append XD_ENT XDLIST))
                    ; Объединить Рданные.
          (setq XD_LIST3 (cons -3 XDLIST))
        ) ;_ End of progn
      ) ;_if assoc RNAME
      (setq ELIST (subst XD_LIST3 (assoc -3 ELIST) ELIST))
                    ; Объединить с примитивом
    ) ;_progn
    (setq ELIST (cons XDLIST ELIST)) ; Пока нет Рданных.
      ) ;_if assoc -3
    ) ;_progn
    (princ (strcat "\nНе хватает памяти для Рданных"
           "- Рданные не добавлены."
       ) ;_ End of strcat
    ) ;_ End of princ
  ) ;_if < xdsize
  ;; Наконец, обновить примитив с Рданными в базе данных.
  (entmod ELIST)
  (princ)
)
(defun RandNum (/ modulus multiplier increment random)
  (if (not *seed*)(setq *seed* (getvar "DATE")))
  (setq  modulus 65536 multiplier 25173 increment  13849
         *seed* (rem (+ (* multiplier *seed*) increment) modulus)
         random (/ *seed* modulus))
)
(defun _get_txt_dictxdName ()
(strcat "MSumT" (substr (vl-string-translate "." "-" (rtos (getvar "CDATE") 2 9)) 3)(itoa (fix (* 100 (RandNum)))))
)
(defun _del_txt_dictxd ( en Rdn / elist sub)
   (setq elist (entget en (list "*")) sub nil)
   (foreach i (cdr (assoc -3 elist))
     (if (not(wcmatch (strcase(car i))(strcase Rdn)))
       (setq sub (append sub (list i)))
       (setq sub (append sub (list(list (car i)))))
       ))
  (setq sub (cons -3 sub)
        elist (subst sub (assoc -3 elist) elist)
        elist (entmod elist))
    )
;;;================================================================================
;;; Функция возвращает Расширенные Данные(РД)  примитива
;;; в виде списка (METKA KOD) или NIL, если РД не присвоено
(DEFUN _get_txt_dictxd (ENAME RNAME / XDLIST ELIST XD_ENT sps)
  (setq ELIST (entget ENAME (list RNAME)))
  (setq XD_ENT (cdr (assoc -3 ELIST)))    ; Старые Рданные.
  ;; Найти старые Рданные для того же приложени
  (if (setq XDLIST (assoc RNAME XD_ENT))
    (progn
      (setq XDLIST (cdr XDLIST))
      (foreach aa XDLIST
    (setq sps (append sps (list (cdr aa))))
      )    
    ) ;_ End of progn
  ) ;_if
  sps
) ;_END defun _get_mark_xd
(defun _get-MSumT_Action ( RDN / MSumT_Action)
 (setq MSumT_Action  (vl-list->string (list(last (vl-string->list RDN)))))
 (if (=  MSumT_Action "M")(setq MSumT_Action "*")(setq MSumT_Action "+"))
  )
(defun C:MSumT_Creat ( / MSumT_Action)
  (setq MSumT_Action (mydcl "Укажите действие цепочки" '("Умножение" "Сложение")))
  (cond ((= MSumT_Action "Умножение")(setq MSumT_Action "*"))
        ((= MSumT_Action "Сложение")(setq MSumT_Action "+"))
        (t nil))
(if MSumT_Action (MSumT_Creat MSumT_Action))(princ))
;;Создает связь между текстами автовычисления и приемником
(defun MSumT_Creat ( MSumT_Action / 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_MSumT_object_reactor (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
     dst MSumT_Action)
    )
  (princ)
  )
(defun C:MSumT? ( / dst reac-list lst RDN dst-list owner-list)
  (vl-load-com)(princ "\nУкажите текст существующей связи")
  (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
    (progn
      (setq dst (ssname dst 0))
      (setq RDN (vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
           (mapcar 'car (car(lib:massoc -3 (entget dst '("*")))))))
     (setq RDN (mapcar '(lambda(x)(cons x (car(_get_txt_dictxd dst x)))) RDN))
     (setq dst (vlax-ename->vla-object dst))
  (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 dst-list (mapcar '(lambda (reac / dat ht en vla-dest)
  (if (vlr-added-p reac)
   (progn
     (setq dat (vlr-data reac))
     (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" dat)))
     (setq en (handent ht))(entget en)
     (setq vla-dest (vlax-ename->vla-object en)))
        vla-dest
       nil
       )))) (vlr-pers-list)))
    (setq lst (mapcar '(lambda(x / rd what act ret)
               (setq rd (car x) what (cdr x)
                act (vl-list->string (list(last (vl-string->list RD)))))
               (list (strcat "Метка цепочки - " rd " ("
                                 (if (= act "M") "умножение" "сложение") ")")
                    (strcat "Тип текста - "
                            (cond ((and (= what "1")(member dst dst-list)) "приемник")
                                  ((and (= what "0")(member dst owner-list)) "источник")
                                  (t "реактор отсутствует"))))) RDN))
   (setq lst (apply 'append lst))(if (null lst)(setq lst (list "Цепочки не найдены")))
   (mydcl "Данные реакторов" lst)(princ))))
;_Добавляет текст к существующей цепочке автосуммы
(defun C:MSumT_Add ( / dst reac-list selset lst *error* RDN)
  (defun *error* (msg)(princ msg)(Restorecolorlist)(princ))
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (if (null RDN)(setq RDN (_get_txt_dictxdName)))
              (setq 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 'MSumT_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(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))))
      (mapcar '(lambda (x)(_add_txt_dictxd x RDN "0")) lst)
       (mapcar 'MSumT_ReactionUpd (reverse reac-list))
      )
    )
  (Restorecolorlist)
  (PurgeAPPID)
  (princ)
  )
(defun C:MSumT_Restore ( / dst reac-list selset lst RDN MSumT_Action)
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (setq dst (vlax-ename->vla-object dst))
             )
             )
           (setq reac-list (vl-remove-if-not '(lambda(reac)(member dst (vlr-owners reac)))(vlr-pers-list)))
           (if reac-list (princ "\nТекст зарегестрирован в цепочке суммирования"))
           (if (null RDN)(princ "\nТекст не помечен в цепочке суммирования"))
           (and (null reac-list) RDN))))
  (if (setq selset (ssget "_X" (list (cons 0  "*TEXT")
                                 (list -3 (list RDN)))))
    (progn
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
      (setq vla-list-owner (vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "0")) lst))
      (setq vla-dest (car(vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "1")) lst)))
      (if (and vla-list-owner vla-dest)
        (progn
          (setq MSumT_Action (_get-MSumT_Action RDN))
          (mapcar '(lambda(x)(_del_txt_dictxd x Rdn)) lst)
          (add_MSumT_object_reactor (mapcar 'vlax-ename->vla-object vla-list-owner)(vlax-ename->vla-object vla-dest) MSumT_Action)
          )
        (princ "\nНе найден текст-сумма или пуст список текстов-слагаемых")
        )
      )
    )
  (PurgeAPPID)
  (princ)
  )
;;Удаляет текст из связи
(defun C:MSumT_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)
    )
  (MSumT_del dst)
    )
    )
  (princ)
  )
;;Удаляет тексты из связи
(defun C:MSumT_Del ( / dst )
  (vl-load-com)
  (princ "\nУкажите тексты для удаления из цепочки")
  (if (setq  dst (ssget "_:L" '((0 . "*TEXT"))))
    (progn
  (mapcar 'MSumT_del (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex dst)))))
    )
    )
  (princ)
  )
;;;Задание цвета цепочке и сумме
(defun C:MSumT_Color ()(SetMSumTColor)(princ))
;;Визуализирует связь
(defun C:MSumT_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)
    )
  (MSumT_Viz dst)
  )
    )
  (princ)
  )
;;Восстанавлиает предыдущее состояние
(defun C:MSumT_VizR ( )(Restorecolorlist))
(mapcar 'princ (list
"\n ====  Определенные команды  ===="
"\nMSumT_Creat - Создает связь между текстами (сумма и умножение)"
"\nMSumT_Add - Добавляет текст к существующей цепочке автосуммы"
"\nMSumT_Del1 - Удаляет текст из связи"
"\nMSumT_Del - Удаляет тексты из связи"
"\nMSumT_Color - Задание цвета цепочке и сумме"
"\nMSumT_Restore - Восстановление цепочки"
"\nMSumT?      - Справка о реакторах"
"\nMSumT_Viz - Визуализирует связь"
"\nMSumT_VizR - Восстанавлиает предыдущее состояние"))
(princ)

Re: Пересчет вычислений продолжение

Классно!! Все работает!!
Я смотрю появилась новая команда "MSumT?" которая показывает "Метку цепочки", очень полезная штучка!!
Как говорится "одна голова хорошо, а две есчо лучше" для идей!
Давай ка ее немножко улучшим:
1. По каким то причинам она показывает только первую цепочку и присваевает ей метку цепочки, а следующие цепочки пишет "цепочки не найдены"!
2. Неплохо чтоб можно было каждой из цепочек присвоить свою метку и ее редактировать при надобности, соответственно ее сохранить!
3. И что самое интересное если всю цепочку скопировать и вставить, после, командой "MSumT?" указать на вставленную (нерабочую) цепочку, то пишет метку цепочки скопированной цепочки.
А так как вставленная цепочка не является цепочкой, то соответственно не имеет ни какой метки!
Можно ли эти пожелания осуществить??
Спасибо  VVA !!!!!

Re: Пересчет вычислений продолжение

Странно, а сечас пробую командой "MSumT?" указываю одну единственную цепочку пишет "цепочки не найдены"??

Re: Пересчет вычислений продолжение

> Сергей

;;Действующая ли цепочка
(defun IsRealChain ( vla-dst / reac-list owner-list dst-list RDN ht e1)
  ;(setq vla-dst (vlax-ename->vla-object (car(entsel))))
  (setq ht (vla-get-handle vla-dst))
  (mapcar
    '(lambda (x)
       (if (/= ht (cadr (_get_txt_dictxd e1 x)))
         (_del_txt_dictxd e1 x)
       ) ;_ end of if
     ) ;_ end of lambda
    (vl-remove-if-not
      '(lambda (x) (wcmatch x "MSumT*"))
      (mapcar
        'car
        (car
          (lib:massoc
            -3
            (entget (setq e1 (vlax-vla-object->ename vla-dst)) '("*"))
          ) ;_ end of lib:massoc
        ) ;_ end of car
      ) ;_ end of mapcar
    ) ;_ end of vl-remove-if-not
  ) ;_ end of mapcar
  (setq reac-list (vl-remove-if-not '(lambda(reac)(member vla-dst (vlr-owners reac)))(vlr-pers-list)))
  (setq owner-list (mapcar 'vlr-owners reac-list))
  (setq owner-list (apply 'append owner-list))
  (setq dst-list (mapcar '(lambda (reac / dat ht1 en vla-dest)
  (if (vlr-added-p reac)
   (progn
     (setq dat (vlr-data reac))
     (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht1 (cadr (assoc  "MSumTDEST" dat)))
     (setq en (handent ht1))(entget en)
         (setq RDN (cadr (assoc "MSumTRDN" dat)))
         (or owner-list
         (= ht (cadr (_get_txt_dictxd e1 RDN))))
     (setq vla-dest (vlax-ename->vla-object en)))
        vla-dest
       nil
       )))) (vlr-pers-list)))
  (setq dst-list (vl-remove-if 'null dst-list))
  (if dst-list vla-dst nil)
  )
(defun MsumT_Check ( echo / ss count lock all)
(setq count 0 lock 0 all 0)
(if (setq ss (ssget "_X" '((0 . "*TEXT") (-3 ("MSumT*")))))
  (progn
    (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq all (1+ all))
      (if (vlax-write-enabled-p item)
        (if (null (IsRealChain item))(setq count (1+ count)))
        (setq lock (1+ lock))
        )
      )
    )
  )
  (if echo (progn
  (princ "\nПроверено\t - ")(princ all)(princ " примитивов")
  (princ "\n   Исправлено\t - ")(princ count)(princ " примитивов")
  (princ "\n   Заблокировано\t - ")(princ lock)(princ " примитивов")))
  (princ))
(defun C:MsumT_Check ()(MsumT_Check t))
(defun C:MSumT? ( / dst reac-list lst RDN dst-list owner-list)
  (vl-load-com)(princ "\nУкажите текст существующей связи")
  (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
    (progn
    (if (and (setq dst (ssname dst 0))
           (IsRealChain (vlax-ename->vla-object dst)))
      (progn
      (setq RDN (vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
           (mapcar 'car (car(lib:massoc -3 (entget dst '("*")))))))
     (setq RDN (mapcar '(lambda(x)(cons x (car(_get_txt_dictxd dst x)))) RDN))
     (setq dst (vlax-ename->vla-object dst))
  (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 dst-list (mapcar '(lambda (reac / dat ht en vla-dest)
  (if (vlr-added-p reac)
   (progn
     (setq dat (vlr-data reac))
     (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" dat)))
     (setq en (handent ht))(entget en)
     (setq vla-dest (vlax-ename->vla-object en)))
        vla-dest
       nil
       )))) (vlr-pers-list)))
    (setq lst (mapcar '(lambda(x / rd what act ret)
               (setq rd (car x) what (cdr x)
                act (vl-list->string (list(last (vl-string->list RD)))))
               (list (strcat "Метка цепочки - " rd " ("
                                 (if (= act "M") "умножение" "сложение") ")")
                    (strcat "Тип текста - "
                            (cond ((and (= what "1")(member dst dst-list)) "приемник")
                                  ((and (= what "0")(member dst owner-list)) "источник")
                                  (t "реактор отсутствует"))))) RDN))
   (setq lst (apply 'append lst))
   (if (null lst)
     (progn
     (setq lst (list "Действующие цепочки не найдены"))
     )
     )
   (princ)
      )
      (setq lst (list "Действующие цепочки не найдены"))
      );_if and
    (mydcl "Данные реакторов" lst)
    )
    )
  (princ)
  )

Обновленная MSumT? + MsumT_Check (удаление у примитивов РД недействующих цепочек). Недостающие ф-ции выше

Re: Пересчет вычислений продолжение

Команда "MsumT_Check" - для чего она???
Я имел ввиду при использовании Команды "MSumT?" и при указании на цепочку выдавало не "Метка цепочки-МSumT070328-1606243938P (сложение)", а "Метка цепочки-ТЕКСТ ВВОДИМЫЙ МНОЮ И В ДАЛЬНЕЙШЕМ ЕГО КОРРЕКТИРОВКА"!!
Короче вместо кода писало то что я впишу!
Вот это возможно?

Re: Пересчет вычислений продолжение

Таким образом можна дать каждой цепочке свое имя, для того что бы при большом количестве цепочек можно было легко с ориентироватся к какой цепочке надо добавить слогаемое!

Re: Пересчет вычислений продолжение

"MsumT_Check" - удаление расширенных данных недействующих цепочек. Можно удалить ненужные расширенные данные у примитивов. Можно не применять. РД подчищаются и в других местах.
Пришлось много чего подправить. Весь код

;https://www.caduser.ru/forum/topic33835.html
;https://www.caduser.ru/forum/topic34287.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 MSumT-in-reac ( K vla-list-owner MSumT_Action / res selset ins_pt txt_height str)
(setq res 0.)
(if (= MSumT_Action "*")(setq MSumT_Action * res 1.0)(setq MSumT_Action + res 0.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 (MSumT_Action res (atof str))))))
(setq res (* K res))
;  (princ "\nРезультат=")(princ (rtos res 2))
res)
(defun add_MSumT_object_reactor ( vla-list-owner vla-dest MSumT_Action str / reac RDN)
  (setq vla-list-owner (vl-remove vla-dest vla-list-owner))
  (setq RDN (_add-MSumT-RD vla-list-owner vla-dest MSumT_Action str))
  (setq reac (vlr-object-reactor vla-list-owner (list '("MSumTRname" "MSumT")
        (list "MSumTAction" MSumT_Action)(list "MSumTDEST" (vla-get-Handle vla-dest))
        (list "MSumTRDN" RDN))(list '(:vlr-modified . MSumT_Reaction))))
  (vlr-pers reac)(MSumT_ReactionUpd reac))
(defun MSumT_Reaction (vlao reac args / vla-dest ht dat en lst MSumT_Action)
  (vl-load-com)
  (if (vlr-added-p reac)(progn
  (setq dat (vlr-data reac))
   (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 MSumT_Action (cadr (assoc  "MSumTAction" dat)))
         (setq ht (MSumT-in-reac 1 lst MSumT_Action))
         (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)
  (cond ((= (type dat) 'INT)(setq dat (itoa dat)))
         ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))))
(defun mydcl (zagl info-list / fl ret dcl_id)
(vl-load-com)(if (null zagl)(setq zagl "Выбор")) ;_ end of if
(setq fl (vl-filename-mktemp "mip" nil ".dcl"))
(setq ret (open fl "w"))
(mapcar '(lambda (x) (write-line x ret))
(list "mip_msg : dialog { " (strcat "label=\"" zagl "\";")
" :list_box {" "alignment=top ;" "width=51 ;"
(if (> (length info-list) 26) "height= 26 ;"
(strcat "height= " (itoa (+ 3 (length info-list))) ";"))
"is_tab_stop = false ;" "key = \"info\";}" "ok_cancel;}"))
(setq ret (close ret))(if (setq dcl_id (load_dialog fl))
(if (new_dialog "mip_msg" dcl_id)(progn (start_list "info")
(mapcar 'add_list info-list)(end_list)(set_tile "info" "0")
(setq ret (car info-list))(action_tile "info" "(setq ret (nth (atoi $value) info-list))")
(action_tile "cancel" "(progn(setq ret nil)(done_dialog 0))")
(action_tile "accept" "(done_dialog 1)")(start_dialog))))
(unload_dialog dcl_id)(vl-file-delete fl) ret)
(defun MSumT_ReactionUpd (reac / vla-dest ht dat en lst MSumT_Action)
   (vl-load-com)
  (if (vlr-added-p reac)
   (progn
  (setq dat (vlr-data reac))
   (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 MSumT_Action (cadr (assoc  "MSumTAction" dat)))
         (setq ht (MSumT-in-reac 1 (vlr-owners reac) MSumT_Action))
         (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 MSumT_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 'MSumT_ReactionUpd (reverse reac-list))
  (_del-MSumT-RD  (vlax-vla-object->ename dst))
    )
(defun _del-MSumT-RD (e1)
  (mapcar '(lambda(x)(_del_txt_dictxd e1 x))
          (vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
            (mapcar 'car (car(lib:massoc -3 (entget e1 '("*")))))))
  (PurgeAPPID)
  )
(defun PurgeAPPID (/ appid)
  (vl-load-com)
  (vlax-for appid (vla-get-registeredapplications
            (vla-get-activedocument
              (vlax-get-acad-object)
            )
          )
    (vl-catch-all-apply 'vla-delete (list appid))
  )
  (princ)
)
(defun _add-MSumT-RD ( vla-list-owner vla-dest MSumT_Action str / currRDName)
  (setq vla-list-owner (mapcar 'vlax-vla-object->ename vla-list-owner))
  (setq vla-dest (vlax-vla-object->ename vla-dest))
  (setq currRDName (vl-string-translate "*+" "MP"
                      (strcat (_get_txt_dictxdName) MSumT_Action)))
  (mapcar '(lambda(x)(_add_txt_dictxd x currRDName "0" str)) vla-list-owner)
  (_add_txt_dictxd vla-dest currRDName "1" str)
  currRDName
  )
(defun SetMSumTColor ( / 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 "MSumT_Color+"(mip-conv-to-str colP))
  (mip-reg-write "MSumT_Color="(mip-conv-to-str colS))
  )
  (defun GetMSumTColor ( / ht )(list
  (if (setq ht (mip-reg-read "MSumT_Color+")) ht "1")
  (if (setq ht (mip-reg-read "MSumT_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 *MSumT-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 *MSumT-obj-list*  nil)
 (princ " ok")(princ)
)
(defun MSumT_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 obj (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 "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" 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 (GetMSumTColor))
    colS (cadr colP)  colP (car colP))
  (setq *MSumT-obj-list* (append *MSumT-obj-list* (mapcar 'getcolorlist owner-list))
        *MSumT-obj-list* (append *MSumT-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Команда MSumT_VizR восстановит цвет текста ")(princ))
(defun lib:massoc (key alist)
 (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
;;;================================================================================
;;; Функция добавляет Расширенные Данные к примитиву
;;; ENAME - Имя примитива
;;; RNAME - имя приложения
;;; DICT - имя словаря примитива (строка)
;;; (-3 ("MIP_XD" (1000 . DICT)(1005.METKA)))
(DEFUN _add_txt_dictxd
       (ENAME RNAME DICT STR  / XDLIST ELIST METKA XD_ENT XD_LIST3)
  (regapp RNAME)
  (setq ELIST (entget ENAME '("*")))
  (setq METKA (cdr (assoc 5 ELIST)))
  (setq XDLIST (list (cons 1000 DICT)(cons 1005 METKA)(cons 1000 STR)))
  (setq XDLIST (list (cons RNAME XDLIST)))
  (setq XDLIST (cons -3 XDLIST))
  (if (< (xdsize XDLIST) (xdroom ENAME)); Если есть еще пространство...
    (progn
      (if (assoc -3 ELIST)        ; и уже есть Рданные...
    (progn
      (setq XDLIST (cdr XDLIST))    ; Новые Рданные.
      (setq XD_ENT (cdr (assoc -3 ELIST))) ; Старые Рданные.
      ;; Найти старые Рданные для того же приложени
      (if (assoc RNAME XD_ENT)
        (progn
          (setq XD_LIST3 (subst (car XDLIST)
                    (assoc RNAME XD_ENT)
                    (assoc -3 ELIST)
                 ) ;_ End of subst
          ) ;_ End of setq
        ) ;_ End of progn
        (progn            ; Это новое приложение...
          (setq XDLIST (append XD_ENT XDLIST)); Объединить Рданные.
          (setq XD_LIST3 (cons -3 XDLIST))
        ) ;_ End of progn
      ) ;_if assoc RNAME
      (setq ELIST (subst XD_LIST3 (assoc -3 ELIST) ELIST)); Объединить с примитивом
    ) ;_progn
    (setq ELIST (cons XDLIST ELIST)) ; Пока нет Рданных.
      ) ;_if assoc -3
    ) ;_progn
    (princ (strcat "\nНе хватает памяти для Рданных"
           "- Рданные не добавлены."
       ) ;_ End of strcat
    ) ;_ End of princ
  ) ;_if < xdsize
  ;; Наконец, обновить примитив с Рданными в базе данных.
  (entmod ELIST)(princ))
(defun RandNum (/ modulus multiplier increment random)
  (if (not *seed*)(setq *seed* (getvar "DATE")))
  (setq  modulus 65536 multiplier 25173 increment  13849
         *seed* (rem (+ (* multiplier *seed*) increment) modulus)
         random (/ *seed* modulus))
)
(defun _get_txt_dictxdName ()
(strcat "MSumT" (substr (vl-string-translate "." "-" (rtos (getvar "CDATE") 2 9)) 3)(itoa (fix (* 100 (RandNum)))))
)
(defun _del_txt_dictxd ( en Rdn / elist sub)
   (setq elist (entget en (list "*")) sub nil)
   (foreach i (cdr (assoc -3 elist))
     (if (not(wcmatch (strcase(car i))(strcase Rdn)))
       (setq sub (append sub (list i)))
       (setq sub (append sub (list(list (car i)))))
       ))
  (setq sub (cons -3 sub)
        elist (subst sub (assoc -3 elist) elist)
        elist (entmod elist))
    )
;;;================================================================================
;;; Функция возвращает Расширенные Данные(РД)  примитива
;;; в виде списка (METKA KOD) или NIL, если РД не присвоено
(DEFUN _get_txt_dictxd (ENAME RNAME / XDLIST ELIST XD_ENT sps)
  (setq ELIST (entget ENAME (list RNAME)))
  (setq XD_ENT (cdr (assoc -3 ELIST)))    ; Старые Рданные.
  ;; Найти старые Рданные для того же приложени
  (if (setq XDLIST (assoc RNAME XD_ENT))
    (progn
      (setq XDLIST (cdr XDLIST))
      (foreach aa XDLIST
    (setq sps (append sps (list (cdr aa))))
      )    
    ) ;_ End of progn
  ) ;_if
  sps
) ;_END defun _get_mark_xd
(defun _get-MSumT_Action ( RDN / MSumT_Action)
 (setq MSumT_Action  (vl-list->string (list(last (vl-string->list RDN)))))
 (if (=  MSumT_Action "M")(setq MSumT_Action "*")(setq MSumT_Action "+"))
  )
(defun C:MSumT_Creat ( / MSumT_Action str)
  (setq MSumT_Action (mydcl "Укажите действие цепочки" '("Умножение" "Сложение")))
  (cond ((= MSumT_Action "Умножение")(setq MSumT_Action "*"))
        ((= MSumT_Action "Сложение")(setq MSumT_Action "+"))
        (t nil))
(if MSumT_Action
  (progn
    (setq str (getstring t "\nОписание цепочки <нет>:"))
    (MSumT_Creat MSumT_Action str))(princ)
  )
  )
;;Создает связь между текстами автовычисления и приемником
(defun MSumT_Creat ( MSumT_Action str / 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_MSumT_object_reactor (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
     dst MSumT_Action str)
    )
  (princ)
  )
;;;(defun C:TEST ()
;;;  (IsRealChain (vlax-ename->vla-object (car(entsel)))))
;;Действующая ли цепочка
(defun IsRealChain ( vla-dst / reac-list owner-list dst-list RDN ht e1)
  ;(setq vla-dst (vlax-ename->vla-object (car(entsel))))
  (setq ht (vla-get-handle vla-dst))
  (mapcar
    '(lambda (x)
       (if (/= ht (cadr (_get_txt_dictxd e1 x)))
         (_del_txt_dictxd e1 x)
       ) ;_ end of if
     ) ;_ end of lambda
    (vl-remove-if-not
      '(lambda (x) (wcmatch x "MSumT*"))
      (mapcar
        'car
        (car
          (lib:massoc
            -3
            (entget (setq e1 (vlax-vla-object->ename vla-dst)) '("*"))
          ) ;_ end of lib:massoc
        ) ;_ end of car
      ) ;_ end of mapcar
    ) ;_ end of vl-remove-if-not
  ) ;_ end of mapcar
  (setq reac-list (vl-remove-if-not '(lambda(reac)(member vla-dst (vlr-owners reac)))(vlr-pers-list)))
  (setq owner-list (mapcar 'vlr-owners reac-list))
  (setq owner-list (apply 'append owner-list))
  (setq dst-list (mapcar '(lambda (reac / dat ht1 en vla-dest)
  (if (vlr-added-p reac)
   (progn
     (setq dat (vlr-data reac))
     (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht1 (cadr (assoc  "MSumTDEST" dat)))
     (setq en (handent ht1))(entget en)
         (setq RDN (cadr (assoc "MSumTRDN" dat)))
         (or owner-list
         (= ht (cadr (_get_txt_dictxd e1 RDN))))
     (setq vla-dest (vlax-ename->vla-object en)))
        vla-dest
       nil
       )))) (vlr-pers-list)))
  (setq dst-list (vl-remove-if 'null dst-list))
  (if dst-list vla-dst nil)
  )
(defun MsumT_Check ( echo / ss count lock all)
(setq count 0 lock 0 all 0)
(if (setq ss (ssget "_X" '((0 . "*TEXT") (-3 ("MSumT*")))))
  (progn
    (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq all (1+ all))
      (if (vlax-write-enabled-p item)
        (if (null (IsRealChain item))(setq count (1+ count)))
        (setq lock (1+ lock))
        )
      )
    )
  )
  (PurgeAPPID)
  (if echo (progn
  (princ "\nПроверено\t - ")(princ all)(princ " примитивов")
  (princ "\n   Исправлено\t - ")(princ count)(princ " примитивов")
  (princ "\n   Заблокировано\t - ")(princ lock)(princ " примитивов")))
  (princ))
(defun C:MsumT_Check ()(MsumT_Check t))
(defun C:MSumT? ( / dst reac-list lst RDN dst-list owner-list)
  (vl-load-com)(princ "\nУкажите текст существующей связи")
  (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
    (progn
    (if (and (setq dst (ssname dst 0))
           (IsRealChain (vlax-ename->vla-object dst)))
      (progn
      (setq RDN (vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
           (mapcar 'car (car(lib:massoc -3 (entget dst '("*")))))))
     (setq RDN (mapcar '(lambda(x / rd )(setq rd (_get_txt_dictxd dst x))(list x (car rd)(caddr rd))) RDN))
     (setq dst (vlax-ename->vla-object dst))
  (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 dst-list (mapcar '(lambda (reac / dat ht en vla-dest)
  (if (vlr-added-p reac)
   (progn
     (setq dat (vlr-data reac))
     (if (and
     (= (cadr (assoc "MSumTRname" dat)) "MSumT")
     (setq ht (cadr (assoc  "MSumTDEST" dat)))
     (setq en (handent ht))(entget en)
     (setq vla-dest (vlax-ename->vla-object en)))
        vla-dest
       nil
       )))) (vlr-pers-list)))
    (setq lst (mapcar '(lambda(x / rd what act ret str)
               (setq rd (car x) what (cadr x) str (caddr x)
                act (vl-list->string (list(last (vl-string->list RD)))))
               (list (strcat "Действие цепочки - " (if (= act "M") "умножение" "сложение"))
                    (strcat "Тип текста - "
                            (cond ((and (= what "1")(member dst dst-list)) "приемник")
                                  ((and (= what "0")(member dst owner-list)) "источник")
                                  (t (if (vlax-write-enabled-p dst)(_del_txt_dictxd (vlax-vla-object->ename dst) rd))
                                       "реактор отсутствует. Будет удален!!!")))
                     (strcat "Примечание-" (mip-conv-to-str str))
                     "------------------------")) RDN))
   (setq lst (apply 'append lst))
   (if (null lst)
     (progn
     (setq lst (list "Действующие цепочки не найдены"))
     )
     )
   (princ)
      )
      (setq lst (list "Действующие цепочки не найдены"))
      );_if and
    (mydcl "Данные реакторов" lst)
    )
    )
  (princ)
  )
;_Добавляет текст к существующей цепочке автосуммы
(defun C:MSumT_Add ( / dst reac-list selset lst *error* RDN)
  (defun *error* (msg)(princ msg)(Restorecolorlist)(princ))
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (if (null RDN)(setq RDN (_get_txt_dictxdName)))
              (setq 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 'MSumT_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(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))))
      (mapcar '(lambda (x)(_add_txt_dictxd x RDN "0" (strcat "Добавлена-" (rtos (getvar "cdate") 2 6)))) lst)
       (mapcar 'MSumT_ReactionUpd (reverse reac-list))
      )
    )
  (Restorecolorlist)
  (PurgeAPPID)
  (princ)
  )
(defun C:MSumT_Restore ( / dst reac-list selset lst RDN MSumT_Action str)
  (vl-load-com)
  (while (not(progn
           (princ "\nУкажите текст существующей связи")
           (if (setq  dst (ssget "_+.:S:E:L" '((0 . "*TEXT"))))
             (progn
              (setq dst (ssname dst 0))
              (setq RDN (car(vl-remove-if-not '(lambda(x)(wcmatch x "MSumT*"))
                        (mapcar 'car (car(lib:massoc -3 (entget dst '("*"))))))))
              (setq dst (vlax-ename->vla-object dst))
             )
             )
           (setq reac-list (vl-remove-if-not '(lambda(reac)(member dst (vlr-owners reac)))(vlr-pers-list)))
           (if reac-list (princ "\nТекст зарегестрирован в цепочке суммирования"))
           (if (null RDN)(princ "\nТекст не помечен в цепочке суммирования"))
           (and (null reac-list) RDN))))
  (if (setq selset (ssget "_X" (list (cons 0  "*TEXT")
                                 (list -3 (list RDN)))))
    (progn
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
      (setq vla-list-owner (vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "0")) lst))
      (setq vla-dest (car(vl-remove-if-not '(lambda(x)(= (car (_get_txt_dictxd x RDN)) "1")) lst)))
      (if (and vla-list-owner vla-dest)
        (progn
          (setq str (getstring t "\nОписание цепочки <нет>:"))
          (setq MSumT_Action (_get-MSumT_Action RDN))
          (mapcar '(lambda(x)(_del_txt_dictxd x Rdn)) lst)
          (add_MSumT_object_reactor (mapcar 'vlax-ename->vla-object vla-list-owner)(vlax-ename->vla-object vla-dest) MSumT_Action str)
          )
        (princ "\nНе найден текст-сумма или пуст список текстов-слагаемых")
        )
      )
    )
  (PurgeAPPID)
  (princ)
  )
;;Удаляет текст из связи
(defun C:MSumT_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)
    )
  (MSumT_del dst)
    )
    )
  (princ)
  )
;;Удаляет тексты из связи
(defun C:MSumT_Del ( / dst )
  (vl-load-com)
  (princ "\nУкажите тексты для удаления из цепочки")
  (if (setq  dst (ssget "_:L" '((0 . "*TEXT"))))
    (progn
  (mapcar 'MSumT_del (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex dst)))))
    )
    )
  (princ)
  )
;;;Задание цвета цепочке и сумме
(defun C:MSumT_Color ()(SetMSumTColor)(princ))
;;Визуализирует связь
(defun C:MSumT_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)
    )
  (MSumT_Viz dst)
  )
    )
  (princ)
  )
;;Восстанавлиает предыдущее состояние
(defun C:MSumT_VizR ( )(Restorecolorlist))
(mapcar 'princ (list
"\n ====  Определенные команды  ===="
"\nMSumT_Creat - Создает связь между текстами (сумма и умножение)"
"\nMSumT_Add - Добавляет текст к существующей цепочке автосуммы"
"\nMSumT_Del1 - Удаляет текст из связи"
"\nMSumT_Del - Удаляет тексты из связи"
"\nMSumT_Color - Задание цвета цепочке и сумме"
"\nMSumT_Restore - Восстановление цепочки"
"\nMSumT?      - Справка о реакторах"
"\nMsumT_Check  - удаление у примитивов РД недействующих цепочек. "
"\nMSumT_Viz - Визуализирует связь"
"\nMSumT_VizR - Восстанавлиает предыдущее состояние"))
(princ)

Re: Пересчет вычислений продолжение

Круто!!
Есчо один прокол:
-создаем цепочку;
-в описание цепочки вписываем "привет"
-вся цепочка имеет описание "привет"
При добавлении к цепочке "привет", слогаемое не имеет описания этой же цепочки.
   Добавленное слогаемое должно иметь описание соответствующей цепочки!!

Re: Пересчет вычислений продолжение

И кстати я заметил что при копировании одной цепочки с одного файла dwg в другой файл dwg и использовании команды "MSumT_Restore — Восстановление цепочки"
все пересчитывает, что и есть ГУД! Тоесть копирование работает!!!!!!!!
Но есть проблемы если с одного файла dwg в другой файл dwg вставляеш одну и ту же цепочку несколько раз (к примеру 3 раза), то он почему-то объединяет все 3 цепочки в одну, что не есть ГУД.
Если вставляешь по одной цепочке в другой файл dwg и используешь команду "MSumT_Restore", типа:
- вставка цепочки  "MSumT_Restore";
- вставка той же цепочки  "MSumT_Restore";
- вставка той же цепочки   "MSumT_Restore" и т.д. то работает отлично!!
Можна сделать так что бы при вставке цепочки либо несколько разных цепочек автоматом вызвалась команда "MSumT_Restore" и востановила вставляемые цепочки???

Re: Пересчет вычислений продолжение

И еще одно!!
При добавлении к цепочке слогаемого. Надо что бы это слогаемое меняло цвет на соответствующий этой цепочке автоматом!!
И при удалениии из цепочки слогаемого. Удаленное слогаемое возвращало цвет white (черный либо белый в зависимости от фона AutoCad)!!