[Red Nova]

Если кто еще не знает, то тут VVA по моей просьбе создал программу для подсчета масс в спецификациях из мтекстов. Программой я очень доволен, все не нарадуюсь. Но как говорится аппетит приходит во время еды. И теперь хотелось бы пойти еще дальше и автоматизировать создание самой спецификации (которую уже потом можно рассчитывать лиспом от VVA). Ведь по большей части на чертеже всегда присутствуют выноски в которых уже есть информация по спецификации, или хотя бы ее часть. Что если одной командой собрать всю информацию из выносок и вписать в шаблон спецификации.
Суть такова.
Я пользуюсь СПДС. Для маркировки позиций использую выноски СПДС. Выноски СПДС имеют две строки, в верхней пишется номер позиции, в нижней данные о профиле.
Предполагаемый лисп должен выбирать все позиционные выноски СПДС имеющиеся в файле (можно и выбрать рамкой часть файла), создавать список из двух столбцов (номер позиции и профиль), затем многократно фильтровать ненужные данные и дублирующие позиции. Полученный список упорядочивается. Затем рамкой выбирается шаблон для спецификации (напомню он из мтекстов), в выбранные строки вписываются данные из упорядоченного списка.

Теперь попробую на конкретном файле объяснить алгоритм более подробно.
Запускаем лисп, создается список с данными из выносок. Затем фильтруем мусор. Для этого надо сперва ввести в лисп пояснение – как выбрать полезные выноски. Дадим определение пригодных для спецификации выносок.
Они должны удовлетворять следующим пунктам.
1. Обе строки выноски содержат информацию.
2. Верхняя строка выноски должна содержать информацию нумерационного характера, нумерация отсчитывается по цифрам и по буквам латинского и русского алфавитов. Можно использовать знак ‘ и “. Допускаемые записи могут иметь такой вид – 1, 2, 3, 4, // а, б, в, г, // a, b, c, d, // 1a, 1b, 1c, // 1, 1’, 1”, 2, 2’ // a1, a2, a3, b, b1, ... (Впрочем для первого приближения можно оставить только 1, 2, 3, 4)
3. Нижняя строка должна начинаться на определенные символы, вот их список
- Знак “-”, слова “Лист” и “Полоса”
- Слово “Труба”, “Тр.” и знак трубы из шрифтов СПДС
- Слово “Уголок” и аналогичные символы из шрифтов СПДС
- Слово “Двутавр” и аналогичные символы из шрифтов СПДС
- Слово “Швеллер” и аналогичные символы из шрифтов СПДС
- Слово “Фланец”, то же “Фл.”
- Стандартный знак диаметра и знак диаметра из шрифтов СПДС
4. Есть и другие критерии, но о них пока не стоит говорить.

Теперь необходимо отсеять дублирующие позиции, но делать это надо так, чтобы отсеять менее информативные выноски. Скажем имеем две выноски первая строка которых имеет тот же номер, а втора строка различается, предположим вотрые строки имеют следующее содержание:
“Тр. Ø89х3.5, L=2500”
“Тр. Ø89х3.5”
Из этих строк выбирается первая, как более информативная, вторая отбрасывается. Если по проще, то для дальнейших действий берем выноску с более длинной второй строкой.

Поскольку информация о профиле вписывается в двух столбцах (Профиль отдельно, длина отдельно) то нам теперь нам надо определится с ними.
Предположим верхняя строка выноски содержит цифру 25. Если нижняя строка выноски не содержит запятых, (на пример “Тр. Ø89х3.5”) то считаем что выноска не несет информацию о длине профиля, тогда в списке соответствующая строка записывается как
(25, Тр. Ø89х3.5, -). Если же запятая есть (на пример “Тр. 89х3.5, L=2500”) То считаем что выноска несет информацию о длине профиля, тогда в списке соответствующая строка записывается как (25, Тр. 89х3.5, L=2500). Если выноска содержит две и более запятых, (на пример “Тр. Ø89х3.5, L=2500, шаг 200”) то отбрасываем информацию идущую после второй запятой.
Далее упорядочиваем список (по номерам позиций).
Если все прошло как планировалось, то применительно к файлу примера список будет такой.
(1, -10х100x100, -)
(2, Тр. Ø89х3.5, L=2500)
(3, “знак уголка шрифта СПДС”75х5, L=800)
(4, “знак двутавра шрифта СПДС”20, -)
(5, “знак швеллера шрифта СПДС”12, L=960)
(6, Ø12 А500c, ΣL=24000)
(7, Ø20 А500c, L=980)

В спецификации есть также столбик с ГОСТ-ом. Чтобы он вписывался автоматически для каждого профиля надо заранее определится с ГОСТ-ом, и записать его в лисп. Так в нашем примере нужно записать следующие госты
Если обозначение профиля начинается на символ “-”, слово “Лист” то это соответствует ГОСТу “ГОСТ 19903-74”
Если обозначение профиля начинается на слова “Труба”или “Тр.” то это соответствует ГОСТу “ГОСТ 10704-91”
Если обозначение профиля начинается на cлово “Уголок” или аналогичные символы из шрифтов СПДС то это соответствует ГОСТу “ГОСТ 8509-93”
Если обозначение профиля начинается на cлово “Двутавр” или аналогичные символы из шрифтов СПДС
то это соответствует ГОСТу “ГОСТ 8239-89”
Если обозначение профиля начинается на слово “Швеллер” или аналогичные символы из шрифтов СПДС
то это соответствует “ГОСТ 8240-97”
Если обозначение профиля начинается на стандартный знак диаметра и знак диаметра из шрифтов СПДС то это соответствует ГОСТу “ГОСТ 5781-82”

Итак добавив ГОСТы к спискам они должны стать такими:
(ГОСТ 19903-74, 1, -10х100x100, -)
(ГОСТ 10704-91, 2, Тр. Ø89х3.5, L=2500)
(ГОСТ 8509-93, 3, “знак уголка шрифта СПДС”75х5, L=800)
(ГОСТ 8239-89, 4, “знак двутавра шрифта СПДС”20, -)
(ГОСТ 8240-97, 5, “знак швеллера шрифта СПДС”12, L=960)
(ГОСТ 5781-82, 6, Ø12 А500c, ΣL=24000)
(ГОСТ 5781-82, 7, Ø20 А500c, L=980)

Формирование списка законченно. Теперь нужно рамкой отметить шаблон спецификации, в которой 4 столбца и n-ное количество строк. Данные их списка вписываются в мтексы спецификации как указанно в файле примера. Если строк выбрано больше чем у списка, то в мтексты лишних строк вписываются символы ###, если строк выбрано меньше чем у списка, то выходит сообщение об ошибке.

Ну вот и все. Больно длинно у меня получилось для первых объяснений. Если вы дошли до этого предложения, то у вас железное терпение. Надеюсь что кому-то эта белиберда покажется интересной.

В конце скажу что крыс сделал первый шаг, и создал лисп формирующий список их строк выносок СПДС. Вот он.

Код:

[Выделить все]

(defun c:get-notes-activex (/ adoc lst)
;; Через ActiveX
  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (vlax-for ent (vla-get-modelspace adoc)
    (if (= (vla-get-objectname ent) "mcsDbObjectNotePosition")
      (setq lst (cons ent lst))
      ) ;_ end of if
    ) ;_ end of vlax-for
  ;; Теперь делай со списком чего хотишь
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

(defun c:get-notes-ent (/ adoc lst _dwgru-conv-pickset-to-list)
;; Через ent*

  (defun _dwgru-conv-pickset-to-list (value / tab item)
    (repeat (setq tab  nil
                  item (sslength value)
                  ) ;_ end setq
      (setq tab (cons (ssname value (setq item (1- item))) tab))
      ) ;_ end repeat
    ) ;_ end defun

  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (setq lst (vl-remove-if-not
              '(lambda (x) (= (cdr (assoc 0 (entget x))) "spdsNotePosition"))
              (_dwgru-conv-pickset-to-list (ssget "_X"))
              ) ;_ end of vl-remove-if-not
        ) ;_ end of setq
  ;; Теперь делай со списком чего хотишь
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

[dextron3]

Код:

[Выделить все]

(setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*,Болт*,Гайка*,Шайба*")
                  (append x '("-"))
                (if (wcmatch (cadr x) "Сетка*")
                  (append x '("м.кв."))
                ) ;_ end of if
                  (append x '("(м.п.)"))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq

не могу найти здесь ошибку...

[Red Nova]

СВ
Удачно закончил настройку лиспа расчета спецификаций spec5d от VVA для армянского языка. Теперь пытаясь настроить ntt под армянский, и должен признать что успехи нулевые. Если в spec5d проблема возникла только с одним видом профиля, то в ntt не заработал ни один профиль с армянским наименованием. Вот мой вариант c попыткой добавить армянские наименования трубы, фланца и проф-листов. В чем я ошибаюсь?

Код:

[Выделить все]

(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
                  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*, \\U+0547\\U+0580\\U+057В\\U+0561\\U+0576*, \\U053d\\U0578\U0572*, \\U0578\\U057d\\U057a\\U0561\\U0571\\U0587*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun

  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
		    
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл" "\\U+0547\\U+0580\\U+057В\\U+0561\\U+0576")
                   (list "Лист чечевица" "Лист ромб" "\\U0539\\U056b\\U0569\\U0565\\U0572 \\U0578\\U057d\\U057a\\U0561\\U0571\\U0587" "\\U0539\\U056b\\U0569\\U0565\\U0572 \\U0577\\U0565\\U0572\\U0561\\U0576\\U056f\\U0575\\U0578\\U0582\\U0576")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр" "\\U053d\\U0578\\U0572." "\\U053d\\U0578\\U0572\\U0578\\U057e\\U0561\\U056f")
		   (list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
                   (list "Болт")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
		   "СТО АСЧМ 20-93" 
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
                   "ГОСТ 7798-703"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
) ;_ end of defun ntt

[CB]

>Red Nova
Ну это и естественно

что успехи нулевые.

т.к. все, что здесь я говорил про функцию wcmatch осталось без внимания...
Возьмем фрагмент кода

Код:

[Выделить все]

(wcmatch
  (vl-string-translate "Tp" "Тр" (cadr x))
  ".....,##\\U+E712*,## \\U+E712*, \\U+0547\\U+0580\\U+057В\\U+0561\\U+0576*, \\U053d\\U0578\U0572*, \\U0578\\U057d\\U057a\\U0561\\U0571\\U0587*"
) ;_ end of wcmatch

и посмотрим синий шаблон:
1. Пробел после запятой указывает, что и в слове этот пробел должен быть перед ним - а он есть?
2. Совершенно непонятно с UNICODE, а именно
здесь у тебя "\U0547\U0580\U057b\U0561\U0576", здесь - "\U+0547\U+0580\U+057B\U+0561\U+0576" (т.е. в верхнем регистре, да еще появились +).
Так что тут уж ты определись, как должно быть на самом деле (в моем понимании должнен быть такой шаблон - ....,\\U+0547\\U+0580\\U+057b\\U+0561\\U+0576*,....
хотя это ты должен сам проверить... (выполни п.2 и п.5 (см.ниже) и результат сюда)
Ну и еще совет - не пытайся сделать все шаблоны сразу, добейся, чтобы сработал сначала один, потом по образу делай другие.
Вот примерный перечень твоих действий:
1. Открываем в VLIDE лисп с функцией ntt и лисп с функций _dwgru-get-spds-text-and-range
2. Загружаем _dwgru-get-spds-text-and-range (двойной клик перед функцией и Load selection в VLIDE)
3. Вносим шаблон в код, указанный выше
4. Загружаем функцию CB-filtr (так же как в п.2).
5. Находим в ntt код

Код:

[Выделить все]

 
(setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
 
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq

выполняем его так же, как и в п.2 и смотрим результат в VLIDE (указываем в чертеже только те объекты, которые нам нужны для проверки)
6. Находим в ntt код

Код:

[Выделить все]

(setq lst (CB-filtr lst))

выполняем его так же, как и в п.2 и смотрим результат в VLIDE
7. После любых изменений в шаблоне, обязательно выполняем п.4
8. Только когда получаем нужный результат в п.6 - вставляем шаблон в LST-AS.

Ну и еще, для всех кому интересно - правило переноса длинного шаблона на следующую строку в функции wcmatch:

Код:

[Выделить все]

(wcmatch "Уголок 20x25"
  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,
  ,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,
  ,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*"
) ;_ end of wcmatch
T 
_$

т.е. перед шаблоном, который переносится на следующую должна быть запятая...

[Red Nova]

CB,

т.к. все, что здесь я говорил про функцию wcmatch осталось без внимания...

Ну без внимания не осталось, но что память у меня на такие вещи оставляет желать лучшего – это да.

2. Совершенно непонятно с UNICODE, а именно здесь у тебя "\U0547\U0580\U057b\U0561\U0576", здесь - "\U+0547\U+0580\U+057B\U+0561\U+0576" (т.е. в верхнем регистре, да еще появились +). Так что тут уж ты определись

Честно говоря уже и не помню откуда пошли разные варианты записи (делал в разные дни и наверное пользовался разными источниками), но факт что все они срабатывают в spec5d. Хотя конечно же лучше привести к единому виду.

Пытаюсь сделать все в той очередности что ты говоришь.
В Vlide скопировал такие коды

Код:

[Выделить все]

;|
* ?-??? str-str-lst
* ????????? ?-??? ?????????? ?? ?????? ??????, ???????????
* ????? ???? ???????? ??? ??????? ????????
* ?????????? ?????? ?????
* ????????? [Type]:
  str - ?????? ??? ??????? [STRING]
  pat - ??????????? [STRING]
*  ?????? ???????
  (setq str "??;???????;????????" pat ";")
  (setq str "?? — ??????? — ????????" pat " — ")
  (str-str-lst str pat)
* ?????? ????????? http://www.autocad.ru/cgi-bin/f1/board.cgi?t=25113OT
|;
(defun str-str-lst (str pat / i)
  (cond ((= str "") nil)
        ((setq i (vl-string-search pat str))
         (cons (substr str 1 i)
               (str-str-lst (substr str (+ (strlen pat) 1 i)) pat)
         ) ;_  cons
        )
        (t (list str))
  ) ;_  cond
) ;_  defun
(defun SortStringWithNumberAsNumber (ListOfString IgnoreCase / NorStrs count)
;;;Function Normalize (add 0 befor number) number in string
;;; Count normalize symbols set in variable count
;;; CAB added count as an argument
  (defun NormalizeNumberInString (str count / ch i pat ret buf)
    (setq i   0
          pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
          ret ""
    ) ;_ end of setq
    (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
      (if (vl-position ch pat)
        (progn
          (setq buf ch) ;_ end of setq
          (while
            (vl-position (setq ch (substr str (setq i (1+ i)) 1)) pat)
             (setq buf (strcat buf ch))
          ) ;_ end of while
          (while (< (strlen buf) count) (setq buf (strcat "0" buf)))
          (setq ret (strcat ret buf))
        ) ;_ end of progn
      ) ;_ end of if
      (setq ret (strcat ret ch))
    ) ;_ end of while
    ret
  ) ;_ end of defun
  ;;-------------------------------------------------
  ;;  function to Count the longest number in string 
  ;;  CAB added to get the correct COUNT
  (defun getcount (lst / count pat)
    (setq count 0)
    (setq pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
    (mapcar
      '(lambda (str / i maxlen ch)
         (setq i 0 maxlen 0)
         (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
           (if (vl-position ch pat) ; number
             (setq maxlen (1+ maxlen))
             (setq count  (max count maxlen) maxlen 0)
           )
         )
	 (setq count  (max count maxlen)) ;_<<< ADD 21.06.2007 by 
       )
      Lst
    )
    count
  )
  ;;===============================================
  (setq count   (GetCount ListOfString)
        NorStrs (mapcar '(lambda (x) (NormalizeNumberInString x count))
                        ListOfString)
  )
  (and IgnoreCase (setq NorStrs (mapcar 'strcase NorStrs)))
  (mapcar '(lambda (x) (nth x ListOfString)) (vl-sort-i NorStrs '<))
)
(defun mip_MTEXT_Unformat ( Mtext / text Str )
  (setq MM Mtext)
  (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
		   (zerop (strlen Text))
		   (= " " (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 mydcl-i (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))) ";")
                  ) ;_ end of if
                  "is_tab_stop = false ;"
                  "key = \"info\";}"
                  "ok_cancel;}"
            ) ;_ end of list
    ) ;_ end of mapcar
    (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 0)
                (action_tile "info" "(setq ret (atoi $value))")
                (action_tile "cancel" "(progn(setq ret nil)(done_dialog 0))")
                (action_tile "accept" "(done_dialog 1)")
                (start_dialog)
            ) ;_ end of progn
        ) ;_ end of if
    ) ;_ end of if
    (unload_dialog dcl_id)
    (vl-file-delete fl)
    ret
) ;_ end of defun
;;; ************************************************************************
;;; * ?????????? DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-ent-to-ename
;;; *
;;; * 26/12/2007 ?????? 0002. ????? ???????????, ????????? ? ??????????: VVA
;;; * 03/12/2007 ?????? 0001. 
;;; ************************************************************************

(defun _dwgru-conv-ent-to-ename (ent / ret)
;;;    ????????? ?????????????? ??????????? ????????? ? ename-???????
;;;    ????????? ??????:
;;;	ent	?????????????? ?????????. ????? ????:
;;;		 ename
;;;		 vla-object
;;;		 ?????? (?????????????? ??? ????? ?????????)
;;;		 ??????, ?????????? ?? (entsel)
;;;		 ??????, ?????????? ?? (entget)
;;;    ??????? ??????:
  ;|
(setq
  entity (vla-addline
        (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
        (vlax-3d-point (setq pt (getpoint)))
        (vlax-3d-point (getpoint pt))
        ) ;_ end of vla-addline
  ) ;_ end of setq
(_dwgru-conv-ent-to-ename entity)	; <Entity name: 7ef5cf68>
|;
  (cond
    ((= (type ent) 'vla-object) (vlax-vla-object->ename ent))
    ((= (type ent) 'ename) ent)
    ((= (type ent) 'str) (handent ent))
;;;((= (type ent) 'str) (handent str))
;;; VVA 26/12/2007 : start
    ((and (= (type ent) 'list)
          (= (type (setq ret (car ent))) 'ename)
          ) ;_ end of and
     ret
     )
    ((= (type ent) 'list) (cdr (assoc -1 ent)))
    (t nil)
;;; VVA 26/12/2007 : end
    ) ;_ end of cond
  ) ;_ end of defun


;;; ************************************************************************
;;; * ?????????? DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * dwgru-string-replace
;;; *
;;; * 03/12/2007 ?????? 0001.  ?????? ????   (ShaggyDoc)
;;; ************************************************************************

(defun dwgru-string-replace (string old_substr new_substr / pos)
;;;    ??????? ?????? ????????? ????????? (old_substr) ? ???????? ?????? (string) ?? ????? (new_substr).
;;;    ????????????????
;;;    ????????? ??????:
;;;	string		???????? ??????
;;;	ols_substr	?????? ?????????
;;;	new_substr	????? ?????????  
    ;;; ???????:
    ;;;   ?????? (String)

;;;* ?????? ??????:
;;;* (dwgru-string-replace "???????? ??????" "?????? ?????????" "????? ?????????")
;;;* ????????? ??? ????????? ???? 'STR ???????? ?????????? ??????? ???? ???????? ? ??????.
;;;* ?????????? ?????? ? ??????? ???? ????????? ?????? ????????? ? ???????? ?????? ?? ?????.
;;;* ????????????? ? ???????? ????????. ???????? ???????????? ?????????? ?? ??????????.
;;;* ??????:
;|  
 (dwgru-string-replace "????? ???? ?????? ? ????????. ????" "??" "??") ;_?????????   "????? ???? ?????? ? ????????. ????"
 (dwgru-string-replace "1  2       3" "  " " ") ;_?????????  "1 2 3"
|;
    (while (setq pos (vl-string-search old_substr string))
        (setq string
                 (strcat
                     (substr string 1 pos)
                     new_substr
                     (dwgru-string-replace
                         (substr string (+ (strlen old_substr) pos 1))
                         old_substr
                         new_substr
                     ) ;_ end of ru-string-replace
                 ) ;_ end of strcat
        ) ;_ end of setq
    ) ;_ end of while
    string
) ;_ end of defun


;;; ************************************************************************
;;; * ?????????? DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-ent-to-vla
;;; *
;;; * 27.12.2007 ???????? VVA
;;; * 03/12/2007 ?????? 0001. 
;;; ************************************************************************
    (defun _dwgru-conv-ent-to-vla (ent / ret)
;;;*    ????????? ?????????????? ??????????? ????????? ? vlax-???????
;;;*    ????????? ??????:
;;;*    ????????? ??????:
;;;*   ent ????????, ??????? ???? ????????????? ? ????????. ?????
;;;*   ????:
;;;*                       -    ?????? ????????? (ename),
;;;*                       -    vla-?????????? (vla-object),
;;;*                       -    ?????? (?????????????? ??? ????? ?????????),
;;;*                       -    ?????? entget,
;;;*                       -    ?????? entsel.
;;;*   ???? ?? ??????????? ?? ?????? ?? ????????? ?????,
;;;*   ???????????? nil
;;;  
;;;* ?????????? ??????? ??????????
;;;                 _dwgru-conv-ent-to-ename

  ;|
(setq entity (entmakex (list (cons 0 "POINT") (cons 10 (getpoint)))))
(_dwgru-conv-ent-to-vla entity) ; #<VLA-OBJECT IAcadPoint 064ad294>
(_dwgru-conv-ent-to-vla (entget(entlast)))
(_dwgru-conv-ent-to-vla (cdr(assoc 5 (entget(entlast)))))
(_dwgru-conv-ent-to-vla (entsel))
(_dwgru-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
|;
  (cond
    ((= (type ent) 'vla-object) ent)
;;; ((= (type ent) 'ename) (vlax-ename->vla-object ent)) ;;;Rem VVA
;;; 27.12.2007
    ((setq ret (_dwgru-conv-ent-to-ename ent)) (vlax-ename->vla-object ret))
;;;Add VVA 27.12.2007

    ;| ;;; Rem VVA 27.12.2007 ??????
;;; ???????????? ???????:
;;;((= (type ent) 'str) (vlax-ename->vla-object (handent ent)))
;; ??????????? Alaspher ?? 28.11.2007. ??????.
   ((= (type ent) 'str)
    (if (setq ent (handent ent))
      (vlax-ename->vla-object ent)
    ) ;_ end of if
   )
;; ??????????? Alaspher ?? 28.11.2007. ?????
;;; Rem VVA 27 12.2007 ?????|;
    (t nil)
    ) ;_ end of cond
  ) ;_ end of defun


;;; ************************************************************************
;;; * ?????????? DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-pickset-to-list
;;; *
;;; * 03/12/2007 ?????? 0001. 
;;; ************************************************************************

(defun _dwgru-conv-pickset-to-list (value / lst item)
 ;;; ??????????:
    ;;; ??????????????? ????? (pickset) ? ??????? ?????? ???? ?????????? (ename)
    ;;; ?????????????? ???????. ???????? ???????????? ????? ?? ????????????

    ;;; ?????????: 
    ;;; value - ????? (pickset) ??? nil ???? ?????? ?????
    ;;; ???????:
    ;;;   - ?????? ?????????? (Ename)
;;;; ??????
  ;|
(setq point (vla-addpoint (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3d-point '(0 0 0))))
(_dwgru-conv-pickset-to-list (ssget "_L")) ;_(<??? ???????: 7ef85e00>)
(_dwgru-conv-pickset-to-list (ssadd)) ;_nil
  |;
       (repeat (setq item (sslength value)) ;_ end setq
         (setq lst (cons (ssname value (setq item (1- item))) lst))
         ) ;_ end repeat
lst
)

; ?-??? mip-put-hyperlink
; ?????????? nil.
; Arguments [Type]:
;   Ename = Object [ENAME]
;  URLDescription = ?????? [STR]
; ???? ?????? "", ?? ?????? ?????????
(defun mip-put-hyperlink (ENAME URLDescription)
  (if (eq (type ENAME) 'ENAME)
    (setq ENAME (vlax-ename->vla-object ENAME))
  ) ;_ end of if
  (vlax-for hyp (vla-get-hyperlinks ENAME) (vla-delete hyp))
  (if (/= URLDescription "")
  (vla-add (vla-get-hyperlinks ENAME)
           "about:blank"
           URLDescription
  ) ;_ end of vla-add
    )
) ;_ end of DEFUN		 

(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)))))



;;;=====================================================================================




;;;http://dwg.ru/f/showthread.php?t=16987
;;;http://dwg.ru/f/showthread.php?t=16987&page=3
;;;?? ????? ????? ??????? ??????????? ??????????? TOKR. ????????? ??????, ???????.
;;;?????? ??????? ????????? ?? ??????????, ?????????, ????? ??????? ????????, ????? ??? ???? ??????????????.
;;;???? ? ?????? ???? ????, ?? ??? ??????????? ??? ??????????? ?????????. ? ??????? ??????????? ?????????? ?????? ? ?????? (???????????? ??),
;;;?? ???? ?? ?????????????. ??? ??????????? ????? ????? ? ???? ??????
;;;(text-round item okr t) ? ???????? ?? (text-round item okr nil)

;|
  ??????????:  ???????????? ??????,???????, ???????? ????????? ??? ??????.
               ??????? ??????? ????????????
  ???????????: ??????????? ? ???????????? ????? ??? ???????. 
               ????? ??????????? ?????? atof ????? ???? "22.3????" 
               ????? ?????? ??? ????? 22.3
 
               ??? ?????? ?????????? ????? ??????????? ? ???????????? 
               ? ????????? ?????????? num.
|;
;;;what - ???????? + ??? *
;;;newtext - t - ????? ?????, nil - ??????? ?????
;;; num - ?????????? ?????? ????? ???????, nil - ?????????? LUPREC
(defun operate_text ( what newtext num / res selset ins_pt txt_height blk obj ed *error*)
  (defun *error* (msg)
    (setvar "NOMUTT" 0)  ;_ ??????????????? NOMUTT
    (princ msg)
    )
 (vl-load-com)(if (eq what '*)(setq res 1.)(setq res 0.))
  (if (null num)(setq num (getvar "LUPREC")))
(princ "\n(?????????? ?? ")(princ num)(princ ") ")  
 (princ "???????? ?????? ??? ???????: ")
  (setvar "NOMUTT" 1)  ;_ ????????? NOMUTT
  (setq selset (ssget '((0 . "TEXT,MTEXT,*DIMENSION"))))
  (setvar "NOMUTT" 0)  ;_ ??????????????? NOMUTT
 (if  selset
    (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
     (setq obj (vlax-ename->vla-object ent)
           ed (entget ent)
           ) 
     (if (and (wcmatch (cdr(assoc 0 ed)) "*DIMENSION")
              (or
                (member '(100 . "AcDbAlignedDimension") ed)  ;_???????????? ??? ????????
                (member '(100 . "AcDbDiametricDimension") ed);_???????
                (member '(100 . "AcDbRadialDimension") ed)   ;_??????
                (member '(100 . "AcDbArcDimension") ed)      ;_???????
                )
              )
       (progn
         (setq blk
             (vla-item (vla-get-blocks
                         (vla-get-activedocument (vlax-get-acad-object))
                       ) ;_ end of vla-get-Blocks
                       (cdr (assoc 2 ed))
             ) ;_ end of vla-item
      ) ;_ end of setq
      (vlax-for item blk
        (if (= (vla-get-objectname item) "AcDbMText")
          (setq obj item)
          )
         )
       )
       )
     (if (vlax-property-available-p obj 'Textstring)
       (progn
	 (setq txt_height (vla-get-Height obj))
     (setq str (str-str-lst (vla-get-textstring obj) "\\P")
     str (mapcar '(lambda(x)(mip_mtext_unformat x)) str)
      str (mapcar '(lambda(x)(vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   x))) str)
      str (mapcar '(lambda(x)(vl-string-trim  "%UuoOcC \t"   x)) str)
     res ((eval what) res (apply what (mapcar 'atof str))))
     )
       )
      ) ;_ end of foreach 
    ) ;_ end of if 
  (princ "\n?????????= ")(princ res)(princ " ? ???????????= ")(princ (rtos res 2 num))
  
  (if (not (equal res 0. 1e-3))
    (if newtext
    (progn 
      (if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0) ;_ end of =
        (progn ;; ??????? ?????? ??????
	 (if (> (setq blk (_get_sumT_TH)) 1e-6)(setq txt_height blk))
   ;;;(if (not (setq txt_height (getreal "\n??????? ?????? ?????? <2.5> : ")))(setq txt_height 2.5)) 
          (vl-cmdf "_.TEXT" "0,0" txt_height 0 (_sumT_prep_Number(rtos res 2 num)))) ;_ end of progn
        (progn ;; ?????????????? ??????
          (vl-cmdf "_.TEXT" "0,0" 0 txt (_sumT_prep_Number(rtos res 2 num)))) ;_ end of progn
         )
      (command "_.copybase" "0,0" (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause) 
      ) ;_ end of progn
     (progn
       (TTC_Paste (_sumT_prep_Number(rtos res 2 num)) nil)
       )
    ) ;_ end of if
    )
   (princ) 
  )
;;;SUMm Text -> New text
(defun c:sumTN ( )
  (setq *sumT_Okr* (_get_sumT_Okr))
  (operate_text '+ t *sumT_Okr*)
   (princ) 
  )
;;;SUMm Text Exist
(defun c:sumTE ( )
  (setq *sumT_Okr* (_get_sumT_Okr))
  (operate_text '+ nil *sumT_Okr*)
   (princ) 
  )
(defun c:mulTN ( )
  (setq *sumT_Okr* (_get_sumT_Okr))
  (operate_text '* t *sumT_Okr*)
   (princ) 
  )
;;;SUMm Text Exist
(defun c:mulTE ( )
  (setq *sumT_Okr* (_get_sumT_Okr))
  (operate_text '* nil *sumT_Okr*)
   (princ) 
  )

(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\n?????, ???????, ??????? ??? ?????? ??? ??????? <?????> >>"))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE



;?????????? T ???? ? ??????? ???? ????
;;; obj — VLA-??????
(defun isFieldAvailable ( obj  / fc )
  (and
    (vlax-method-applicable-p obj 'FieldCode) ;_???? ????? FieldCode
    (setq fc (vlax-invoke obj 'FieldCode))
    (vl-string-search "%<\\Ac" fc)
    (vl-string-search ">%" fc)
   )
)
;;;?? ????? ????? ??????? ??????????? ??????????? TOKR. ????????? ??????, ???????.
;;;?????? ??????? ????????? ?? ??????????, ?????????, ????? ??????? ????????, ????? ??? ???? ??????????????.
;;;???? ? ?????? ???? ????, ?? ??? ??????????? ??? ??????????? ?????????. ? ??????? ??????????? ?????????? ?????? ? ?????? (???????????? ??),
;;;?? ???? ?? ?????????????. ??? ??????????? ????? ????? ? ???? ??????
;;;(text-round item okr t) ? ???????? ?? (text-round item okr nil)

(defun C:TOKR ( / *error* ss item entity ent okr l0 dimz)
  (defun *error* (msg)(princ msg)(setvar "DIMZIN" dimz)(princ))
  (setq dimz (getvar "DIMZIN"))
  (setq okr (_get_sumT_Okr))
  (princ "\n?????????? ?????? ?????????? <")
  (princ okr)(princ " >:")
  (initget 4)
  (if (null (setq okr (getint)))(setq okr *sumT_Okr*))
(initget "Yes No ?? ??? _Yes No Yes No")
(setq l0 (getkword "\n????????? ?????????? ?????????? ???? [??/???] <??>: "))
(if (= l0 "No")(setvar "DIMZIN" 0)(setvar "DIMZIN" 8))
(and
  okr
  (princ " ???????? ??????")
  (setq ss (ssget "_:L" '((0 . "*TEXT"))))
  (foreach item (_dwgru-conv-pickset-to-list ss)
    (text-round item okr t)
    )
  )
  (setvar "DIMZIN" dimz)
  (setq ss nil)
  (princ)
  )
(defun combine (inlist is-greater is-equal / sorted current result)
  (setq sorted (sort inlist is-greater))
  (setq current (list (car sorted)))
  (foreach item (cdr sorted)
    (if (apply is-equal (list item (car current)))
      (setq current (cons item current))
      (progn
        (setq result (cons current result))
        (setq current (list item))
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of foreach
  (cons current result)
) ;_ end of defun

;; can be used for list of most kinds of atoms:

(defun atomic-combine (lst)(combine lst '> 'eq)) ;_ end of defun
(defun sort (lst predicate)
  (mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst predicate))
) ;_ end of defun


;;; ?????????? ??????
;;; text - ename or vla ??????
;;; num - ???-?? ?????? ??????????
;;; IgnoreField - t - ??????????? ????
;;;             nil - ??? (?????????? ?????? ? ??????)
(defun text-round ( text num IgnoreField )
  (if (and
	(setq text (_dwgru-conv-ent-to-vla  text))
	(vlax-property-available-p text 'Textstring)
	(or IgnoreField
	    (apply 'and (list (null IgnoreField)
			      (null (isFieldAvailable text)
				    )
			      )
		   )
	    )
	)
    (progn
     (setq str (str-str-lst (vla-get-textstring text) "\\P")
     str (mapcar '(lambda(x)(mip_mtext_unformat x)) str)
      str (mapcar '(lambda(x)(vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   x))) str)
      str (mapcar '(lambda(x)(vl-string-trim  "%UuoOcC \t"   x)) str)
      str (mapcar '(lambda(x)(rtos x 2 num))(mapcar 'atof str))
      str (mapcar '_sumT_prep_Number str)
      str (if (> (length str) 1)
	    (vl-string-right-trim "\\P" (apply 'strcat (mapcar '(lambda(x)(strcat x "\\P")) str)))
	    (car str)
	    )
	   )
      (vla-put-TextString text str)
     )
    )
  text
)
;;;MULtiplication of the Text by Columns
;;;???????????? ?????? ?????????
(defun C:mulTC ( / nab pt1 pt2 i col mass SUM h itog t1 t2 okr)
(vl-load-com)
(setq okr (_get_sumT_Okr))
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")  
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ??????????. ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))  
(if nab
  (progn
  (setq col (mapcar ' vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab))))
	col (vl-sort col '(lambda(x y)
	       (> (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint x))))
	       (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint y))))))))
  ));_if
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")  
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ?????. ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab nil nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))  
(if nab
(setq mass (mapcar ' vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab))))
	mass (vl-sort mass '(lambda(x y)
	       (> (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint x))))
	       (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint y))))))))
  );_if
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")  
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ????. ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab nil nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))  
(if nab
(setq itog (mapcar ' vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab))))
	itog (vl-sort itog '(lambda(x y)
	       (> (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint x))))
	       (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint y))))))))
  );_if
(if (and col mass itog
	 (= (length col)(length mass)(length itog))
	 )
    (progn
      (setq i 0 SUM 0)
      (princ "\n??????????\t?????\t????")
      (foreach item col
	(setq t1 (vla-get-TextString item))
	(setq t1 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t1)))
        (setq t1 (mip_mtext_unformat t1))
	(setq t1 (atof t1))
	(setq t2 (vla-get-TextString (nth i mass)))
	(setq t2 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t2)))
        (setq t2 (mip_mtext_unformat t2))
	(setq t2 (atof t2))
	
	(terpri)
	(princ t1)(princ " * ")
	(princ t2)(princ " = ")
	(setq SUM (* t1 t2))
	(princ sum)
	(setq pt1 (nth i itog))
	(if (vlax-write-enabled-p pt1)
	  (vla-put-TextString pt1 (_sumT_prep_Number(rtos sum 2 okr))))
	(setq i (1+ i))
	)
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
(princ)
);_defun
;;;MULtiplication of the Text by Columns
;;;???????????? ?????? ?????????
(defun C:mulTCv2 ( / nab pt1 pt2 i col mass SUM h itog t1 t2 okr fuzz)
(vl-load-com)
(setq okr (_get_sumT_Okr))
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ??????????, ????? ? ???? ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
  
  
(setq col (vl-remove-if 'null (mapcar 'car nab)))
(setq mass (vl-remove-if 'null (mapcar 'cadr nab)))
(setq itog (vl-remove-if 'null (mapcar 'caddr nab)))
(if (and col mass itog
	 (= (length col)(length mass)(length itog))
	 )
    (progn
      (setq i 0 SUM 0)
      (princ "\n??????????\t?????\t????")
      (foreach item col
	(setq t1 (vla-get-TextString (_dwgru-conv-ent-to-vla item)))
	(setq t1 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t1)))
        (setq t1 (mip_mtext_unformat t1))
	(setq t1 (atof t1))
	(setq t2 (vla-get-TextString (_dwgru-conv-ent-to-vla(nth i mass))))
	(setq t2 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t2)))
        (setq t2 (mip_mtext_unformat t2))
	(setq t2 (atof t2))
	
	(terpri)
	(princ t1)(princ " * ")
	(princ t2)(princ " = ")
	(setq SUM (* t1 t2))
	(princ sum)
	(if (and
	      	(setq pt1 (nth i itog))
		(setq pt1 (_dwgru-conv-ent-to-vla pt1))
		(vlax-write-enabled-p pt1)
		)
	  (vla-put-TextString pt1 (_sumT_prep_Number(rtos sum 2 okr))))
	(setq i (1+ i))
	)
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
(princ)
);_defun



;;;GSUM - ????????? ????????????
;;;????????? ???????- ?????
;;;????? ??????? ??????? ?????????? ? ?????
(defun C:GSUM ( / nab pt1 pt2 i col mass SUM h itog t1 t2 okr fuzz)
(vl-load-com)
(setq okr (_get_sumT_Okr))
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(initget 1)
(setq pt1  (getpoint "??????? ?????? ??????? ?????????? ? ????? ?????? ?????: "))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
(mapcar '(lambda(x)(length x)) nab)
(setq mass nil col nil itog nil)
  
(setq col (mapcar '(lambda(x)
           (setq x (reverse x)
               mass (cons (car x) mass)
                 x (reverse (cdr x))
                 )
           )
          
        nab)
      )
(setq mass (reverse mass))
(if (and (apply '= (mapcar 'length nab))
         col mass
	 (= (length col)(length mass))
        )
    (progn

(setq itog(mapcar '(lambda(col1 mas)
           (setq t2 (vla-get-TextString (_dwgru-conv-ent-to-vla mas)))
           (setq t2 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t2)))
           (setq t2 (mip_mtext_unformat t2))
           (setq t2 (atof t2))
           (mapcar '(lambda(y)
                      (setq t1 (vla-get-TextString (_dwgru-conv-ent-to-vla y)))
                      (setq t1 (vl-string-translate "," "." (vl-string-trim  "%UuoOcC \t"   t1)))
                      (setq t1 (mip_mtext_unformat t1))
                      (setq t1 (atof t1))
                      (setq t1 (* t1 t2))
                      )
                   col1
                   )
           )
        col
        mass
     )
      )
(setq itog
       (mapcar '(lambda(x)(apply '+ x))
               (apply 'mapcar (cons 'list itog))
               )
      )
(if (> (length nab) 1)
  (progn
    (setq pt1 (reverse (mapcar '(lambda(x)(cdr(assoc 10 (entget x)))) (mapcar 'car nab))))
    (setq pt2 (abs(- (abs(cadr(cadr pt1)))(abs(cadr(car pt1))))))
    (setq t2 (list 0 (- 0. pt2) 0))
    )
  (progn
    (setq pt1 (cdr (assoc 40 (entget(caar nab)))))
    (setq t2 (list 0 (- 0. (* 2.0 pt1) 0)))
    )
  )
    (setq i '-1 SUM (1- (length (last nab))))
    (foreach txt (last nab)
        (setq i (1+ i))
        (setq t1 (entget txt))
        (setq pt1 (mapcar '+ (cdr(assoc 10 t1)) t2))
        (setq pt2 (mapcar '+ (cdr(assoc 11 t1)) t2))
        (setq t1 (subst (cons 10 pt1)
                        (assoc 10 t1)
                        t1)
              )
      (setq t1 (subst (cons 11 pt2)
                        (assoc 11 t1)
                        t1)
              )
      (if (< i SUM)
        (progn
          (setq t1 (subst (cons 1 (_sumT_prep_Number(rtos (nth i itog) 2 okr)))
                          (assoc 1 t1)
                          t1
                          )
                )
          (entmakex t1)
          )
        )
      
      )
    

  
  )
  (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
(princ)
);_defun`


;;;????????? ?????????? ??????? ?????
(defun mark_parser (str / i buf)
 ;;;??????? ????????????? ? ?????????????, ???????, ????? ????????? 
 (setq str (vl-string-trim  "%UuoO \t" str))
 ;;;?????????, ???????????? ?? UNICOD ??????? (???? \U+EXXXX)
 (if (= (substr str 1 3) "\\U+")
   (setq buf (substr str 1 7) str (substr str 8))
   (setq buf "")
   )
 (while (setq i (VL-STRING-SEARCH "\\U+" str))
   (setq str(dwgru-string-replace str (substr str (1+ i) 7) ""))
   )
   
 (setq str (vl-string-trim  "%UuoO \t" str))
  ;;;??????? ? ??????? ?????? ???????-????????
  ;;; ???? ??? ??? ???????
  ;;;?????? ????????? ? ???????? ???????
 (mapcar '(lambda(txt)
            (setq str(dwgru-string-replace str txt ""))
            )
         '("%%U" "%%O" "%%C" "\\U+E712")
         )
            
 (setq i 0 )
   (while (not(vl-position (substr str (setq i (1+ i)) 1)
            '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "")
            )
              )
     )
  (if (> i 0)(setq i (1- i)))
  (list
    (strcat buf (strcase(vl-string-trim  "%UuoO \t"  (substr str 1 i))))
    (strcase(vl-string-trim  "%UuoO \t" (if (zerop i) str (substr str (1+ i)))))
    )
  )
(defun find-prokat-ves ( tip marka obz wcm / ret MPROF)
;;;tip -??? ???????????
;;; ??? - ??? ???????
;;; "?" - ????????
;;; "?" - ??????
;;; "?" - ????????
;;; "?" - ???????
;;; "?" - ????????
;;;marka - ????? ???????
;;;obz - ??????????? ??? Nil - ?????
;;; wcm - ??????? ?????? 
;;;                     0 - assoc
;;;                     1 - wcmatch -  ?????? ????a
;;;                     2 - wcmatch  - ?????? ?????? ? ???? 
;;;???? ????? ?????????? ? ?????, ?? ???? ?? assoc ????? ?? wcmatch
  (setq ret (vl-remove-if '(lambda(xy)(null (car xy)))
  (mapcar '(lambda(y / pat pat1 sym rr)
             (setq pat (mip-conv-to-str(nth 2 y)))
             (setq pat1 (str-str-lst pat "&"))
             (setq pat (mip-conv-to-str(car pat1)))
             (setq pat1 (mip-conv-to-str(cadr pat1)))
             (if (= (setq sym(substr pat1 1 1)) "~")
               (setq pat1 (substr pat1 2))
               (setq sym "")
               )
             (setq pat (vl-string-translate ";" ","  pat))
             (setq pat1 (vl-string-translate ";" ","  pat1))
             (setq pat (str-str-lst pat ","))
             (setq pat1 (str-str-lst pat1 ","))
             (if (null pat1)(setq pat1 ""))
             (setq pat (apply 'strcat (mapcar '(lambda(z)(strcat "*" (vl-string-trim " *" z) "*,"))pat)))
             (if (= pat1 "") (setq pat1 "*" sym "")
                    (setq pat1 (apply 'strcat (mapcar '(lambda(z)(strcat sym "*" (vl-string-trim " *" z) "*,"))pat1)))
                    )
             (if (and
                 (or (null obz) (wcmatch obz pat))
                 (wcmatch obz pat1)
                 )
               (if (listp (car(last y)))
                 (cond
                   ((= wcm 1);_?????? ????a
                    (setq MPROF (vl-remove-if-not '(lambda(z1)
                                      (wcmatch (car z1)(strcat "*" marka "*"))
                                      )(last y))
                          rr (cadar MPROF)
                          MPROF (caar MPROF)
                          )
                    )
                   ((= wcm 2);_?????? ?????? ? ????
                     (setq MPROF (vl-remove-if-not '(lambda(z1)
                                      (wcmatch marka(strcat "*" (car z1)  "*"))
                                      )(last y))
                                rr (cadar MPROF)
                           MPROF (caar MPROF)
                           )

                    )
                   (t ;_assoc
                     (setq MPROF (assoc marka (last y))
                               rr  (cadr MPROF)
                           MPROF (car MPROF)
                           )
                           )
                   )
                 
                 (if (zerop (car(last y)))
                   (setq rr 0)
                   (setq rr nil)
                   )
                 )
               (setq rr nil)
               )
             (list rr MPROF)
             )
          (if tip (vl-remove-if-not '(lambda(x)(= tip (car x))) *PROKAT_VES_BASE*)
                   *PROKAT_VES_BASE*)
          )
    )
        )
  (setq *MPROF* (cadar ret))
  (mapcar 'car ret)
)

(defun find-sortament-GOST ( tip obz / ret)
  (setq obz(mip-conv-to-str obz))
  (setq tip(mip-conv-to-str tip))
  (setq *PROKAT_KLASS* "")
;;;tip -??? ???????????
;;; ??? - ??? ???????
;;; "?" - ????????
;;; "?" - ??????
;;; "?" - ????????
;;; "?" - ???????
;;; "?" - ????????
;;; nil - ?????
;;;marka - ????? ???????
;;;obz - ???????????
;;;??????? ??????? ????? ??? ""  


  (mip-conv-to-str
  (car
  (setq ret (vl-remove-if 'null
  (mapcar '(lambda(y / pat pat1)
             (setq pat (mip-conv-to-str(nth 2 y)))
             (setq pat1 (str-str-lst pat "&"))
             (setq pat (mip-conv-to-str(car pat1)))
             (setq pat (vl-string-translate ";" ","  pat))
             (setq pat (str-str-lst pat ","))
             (setq pat (apply 'strcat (mapcar '(lambda(z)(strcat "*" (vl-string-trim " *" z) "*,"))pat)))
             (if (wcmatch obz pat)
               (progn
               (setq *PROKAT_KLASS* (nth 3 y))
               (car (str-str-lst (setq pat (mip-conv-to-str(nth 2 y))) ";"))
               )
               nil
               )
             )
           (if (= tip "") *PROKAT_VES_BASE*
           (vl-remove-if-not '(lambda(x)(= tip (car x))) *PROKAT_VES_BASE*))
                   
          )
    )
        )
  )
  )
)
;;;?-??? ?????????? ???? ? ????? ??????
;;;Err - integer
(defun _get_Err_color_string ( Err / ErrColor ErrString )
  (cond
    ((= Err 1)
     (setq ErrColor acRed ErrString "?? ??????? ? ????")
     )
    ((= Err 2)
     (setq ErrColor acBlue ErrString " ?????? 1 ? ????, ???? 1-? ?????????") 
     )
    ((= Err 4)
     (setq ErrColor acBlue ErrString " ???? ? ???? ???. ???????? ?? ???????")
     )
    ((= Err 8)
     (setq ErrColor acRed ErrString " ??????? ?? ???????")
     )
  (t (setq ErrColor acByLayer ErrString ""))
    )
  (list ErrColor ErrString)
  )

;;; ?-??? ?????????? ??? ???????
;;; obz - ??????????? (?????????? ? ?????????????)
;;; ?????????? ???_??????? ??? nil
(defun _get_Prokat_TIP ( obz )
  (if (null *PROKAT_VES_BASE*)(_read-prokat-base))
    (setq ret (vl-remove-if 'null
  (mapcar '(lambda(y / pat pat1)
             (setq pat (mip-conv-to-str(nth 2 y)))
             (setq pat1 (str-str-lst pat "&"))
             (setq pat (mip-conv-to-str(car pat1)))
             (setq pat (vl-string-translate ";" ","  pat))
             (setq pat (str-str-lst pat ","))
             (setq pat (apply 'strcat (mapcar '(lambda(z)(strcat "*" (vl-string-trim " *" z) "*,"))pat)))
             (if (wcmatch obz pat)
               (list (car y))
               )
             )
          *PROKAT_VES_BASE*
          )
    )
        )
  (cond ((= (length ret) 1)(caar ret))
        ((null ret) nil)
        ((apply '= (apply 'append ret))(caar ret))
        (t nil)
        )
  )
;;;???? ?? ???????? ?????

(defun IzPM ( x )
  (or
    (wcmatch (setq x (strcase x)) "*?.?*")  ;_???????? ?????
    (wcmatch x "*?.?*")
    (wcmatch x "*? ?*")
    (wcmatch x "*? ?*")
    (wcmatch x "*??*")
    (wcmatch x "*??*")
    )
  )
(defun _sumT_Ves_okr ( ves)
  ;;;???? ??? ????? ?????? ?????? 100 ????? (0.1), ?? ????????? ?? 4 ??????
  (if (< ves 0.1)
       (rtos ves 2 4)
       (rtos ves 2 (_get_sumT_Okr))
    )
  )
;;;?-??? ?????????? ??? ???????
(defun _get_Prokat_ves ( obzn naim DLN count / what L ves_det_all ves_det_1 ErrCod *STAL* kF Diam Ts Sh Vs kFAll Mprof)
  ;;;?-??? ?????????? ??? ???????
  ;;; obzn - ?????? ??????????? String
  ;;; naim - ?????? ???????????? String
  ;;; DLN - real ????? Real ? ??
  ;;; count - ?????????? Real
  ;;; ?????????? ??????  ????? (???_??????_???????? ???_????? ???_??????)
  ;;;Errcod
  ;;; 0 -??? ??
  ;;; 1 - ??? ? ????
  ;;; 2 - ?????? 1 ? ???? ???? 1-? ?????????
  ;;; 4 - ???? ? ???? ???, ???????? ?? ???????
  ;;; 8 - ??????????
(if (null *PROKAT_VES_BASE*)(_read-prokat-base))  
(setq Errcod 0 what (mark_parser naim))
;;;?????????? ??? ??????? ?? ????
(if (setq L  (_get_Prokat_TIP obzn))
  (setq what (list L (cadr what)))
  (setq what (list (vl-string-trim  "%UuoO \t.," (dwgru-string-replace  (mip-conv-to-str(car (str-str-lst (car what) " "))) "%%?" ""))
               (cadr what)))
  )
(setq *STAL* 0.00000785) ;_????????? ?????
(setq kFAll 1) ;_?????????? ???????
;;; ??? - ??? ???????
;;; "?" - ????????
;;; "?" - ??????
;;; "?" - ????????
;;; "?" - ??????? ?????????? ??? ?????????????, ????????? ?? ????????
;;; "?" - ????????
;;; "????" - ?????? ????????, ????????? ?? ????????. ?? ???????? ? ???? ?????, ?.?. ????? ?????, ?????
;;; ?????????? ??? ???????
;;; "????????????" - ????? ???????, ????????? ?? ????????. ???????? ? ???? ?????, ?.?. ????? ?????, ?????
;;; ?????????? ??? ???????
;;;"?????" - ??????????????? ????. ????? ?????? ?? ??????? ?????????
(setq Mprof (cadr what))  
(cond
;;;======= ??????? + ????? ???? E ???????? ?? ??????? ?
  ((vl-position (car WHAT) '("?" "???????" "??????" "[" "\\U+E725" "\\U+E724" "\\U+E726" "\\U+?725" "\\U+?724" "\\U+?726")) ;_???????
   (if (vl-position (car WHAT) '("\\U+E724" "\\U+E726" "\\U+?724" "\\U+?726")) ;_??????? ????????
     (setq kFAll 2)
     )
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "?" L (if (= obzn "") naim obzn) 0))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   (setq *MPROF* (STRCAT "??????? " (MIP-CONV-TO-STR *MPROF*)))
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
;;;??????? ???????? ???????? ?????? ? ??????????????? ??????? ??? ????????????? ???? 24045-94
((vl-position (car WHAT) '("?????")) ;_ __/--\__
 (setq kFAll 1)
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "?????" L (if (= obzn "") naim obzn) 1))
   (setq *MPROF* (STRCAT "???? ?????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("??")) ;_ ????? ??????????? ? ???????? ???????? ??????????? ???? 19425-74
 (setq kFAll 1)
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "??" L (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("????" "?????" "?????")) ;_ ????? ??????????? ? ???????? ???????? ??????????? ???? 19425-74
 (setq kFAll 1)
;;; (setq L (dwgru-string-replace (cadr what) " " ""))
;;;   (setq L (vl-string-translate "X" "?" (car(str-str-lst L " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
;;;                                                                             ;;;_ ???????? ?? ???????
;;;   (setq L (vl-string-trim  "%UuoO \t.," L))
  (setq L(find-prokat-ves (car WHAT) obzn (if (= obzn "") naim obzn) 2))
  ;;;;??????? ??????? *[]
 (setq *MPROF* ((lambda(str pat)
                  (setq str (vl-string->list str))
                  (mapcar '(lambda(nom)
                             (setq str (vl-remove nom str))
                             )
                          (vl-string->list pat)
                          )
                  (VL-LIST->STRING str)
                  )
                 (MIP-CONV-TO-STR *MPROF*) "*[] "
                 )
       )
  (setq *MPROF* (STRCAT (car WHAT) " " *MPROF*))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ;_ ves_det_1   (* ves_det_1 DLN)
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("?????")) ;_ ????? ?????? ???? 5336-80
 (setq kFAll 1)
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
  (setq L(find-prokat-ves (car WHAT) obzn (if (= obzn "") naim obzn) 2))
  (setq *MPROF* (STRCAT "????? ??????" " " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )  
((vl-position (car WHAT) '("???????")) ;_????? ???????? ? ??????????? ? ?????????? ????????? ???? 8568-77
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
   (setq kFAll 1)                                                                           ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L (str-str-lst L "?"))
 ;;;???? ?? min ???????? - ???????
   (setq Vs (mapcar 'atof L))
   (setq Ts (apply 'min Vs))
   (setq Vs (vl-remove Ts Vs))
   (setq Vs (mapcar '(lambda(x)(* x 0.001)) Vs)) ;_????????? ? ?
   (setq Ts (rtos Ts 2 1))
   (setq Ts (dwgru-string-replace Ts ".0" ""))
   ;;;??????????? ??? ?????????? ????????
 
   (setq L (find-prokat-ves "???????" Ts (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "???????? ???? " (if (wcmatch obzn "*?????*") "?????. " "???? ")(MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* (apply '* Vs) ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("??????")) ;_????? ???????? ????????-???????? ?? 36.26.11-5-89
   (setq L (vl-string-translate "X" "?" (cadr what))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
   (setq kFAll 1)                                                                           ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L (str-str-lst L "?"))
 ;;;???? ?? min ???????? - ???????
   (setq Ts (car L))
   (setq Vs (mapcar 'atof (cdr L)))
   (setq Vs (mapcar '(lambda(x)(* x 0.001)) Vs)) ;_????????? ? ?
   ;;;??????????? ??? ?????????? ????????

   ;;;??????????? ??? ?????????? ???????? ??? 
   (setq L (find-prokat-ves "???????" Ts (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "???????? ???? " (if (wcmatch obzn "*\U0578\U057d\U057a\U0561\U0571\U0587*") "\U0578\U057d\U057a\U0561\U0571\U0587 " "\U0577\U0565\U0572\U0561\U0576\U056f \U0575\U0578\U0582\U0576 ")(MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* (apply '* Vs) ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
((vl-position (car WHAT) '("??????")) ;_????? ???????? ????????-???????? ?? 36.26.11-5-89
   (setq L (vl-string-translate "X" "?" (cadr what))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
   (setq kFAll 1)                                                                           ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L (str-str-lst L "?"))
 ;;;???? ?? min ???????? - ???????
   (setq Ts (car L))
   (setq Vs (mapcar 'atof (cdr L)))
   (setq Vs (mapcar '(lambda(x)(* x 0.001)) Vs)) ;_????????? ? ?
   ;;;??????????? ??? ?????????? ???????? ???
 
   (setq L (find-prokat-ves "??????" Ts (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "???? ????????-???????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* (apply '* Vs) ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )  
((vl-position (car WHAT) '("??????"))
 (setq kFAll 1)
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ??????
                                                                             ;;;_ ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "??????" L (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "?????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ;;??? ?????? ????????? ???-?? ??????? ??? ??????????
         ;;ves_det_1   (if (_get_sumT_Ves1)(atof(rtos ves_det_1 2 (_get_sumT_Okr))) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )  
;;;======= ??????? +
  ((vl-position (car WHAT) '("?" "???????" "\\U+E729" "\\U+E72A" "\\U+?729" "\\U+?72?")) ;_???????
   (if (vl-position (car WHAT) '("\U+E72A" "\U+?72?")) ;_??????? ???????
     (setq kFAll 2)
     )
   (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
   (setq L (vl-string-trim  "%UuoO \t.," L))
   (setq L(find-prokat-ves "?" L (if (= obzn "") naim obzn) 0))
   (setq *MPROF* (STRCAT "??????? " (MIP-CONV-TO-STR *MPROF*)))
   (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
   (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
   (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
   (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
         ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
         ves_det_all (* count ves_det_1 kFAll))
   )
;;;======= ????????            +
   ((vl-position (car WHAT) '("?" "C" "?" "\\U+E712" "\\U+?712")) ;_????????
     (setq Diam (atof (cadr what))) ;???????
     (setq L(find-prokat-ves "?" (itoa (fix Diam)) (if (= obzn "") naim obzn) 0))
    (setq *MPROF* (STRCAT "???????? d= " (rtos Diam 2 0)))
    (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
    (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
(cond ((null L)
       (setq  Errcod 4 ves_det_1 nil)) ;_??? ? ???? ??????? ?? ???????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
     (if ves_det_1
       ;;;????? ??? ?? ????
       (if (IzPM obzn)
       (setq ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
             ves_det_all (* count ves_det_1 DLN (if (< DLN 5) 1 0.001)))  
       (setq ves_det_1 (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
             ves_det_1   (if (_get_sumT_Ves1)(atof(rtos ves_det_1 2 (_get_sumT_Okr))) ves_det_1)
             ves_det_all (* count ves_det_1))
         )
       ;;;??? ???????? ?????????? ??? ?? ???????? ?? 0.5 ???????? ? ???????? ???????? ?? ????? ? ?? *STAL*
       (if (IzPM obzn)
       (setq Errcod 4 ves_det_1 (* pi 0.25 Diam Diam 1000 *STAL*)
             ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
             ves_det_all (* count ves_det_1 DLN))
         (setq Errcod 4 ves_det_1 (* pi 0.25 Diam Diam DLN *STAL*)
             ves_det_1   (if (_get_sumT_Ves1)(atof(rtos ves_det_1 2 (_get_sumT_Okr))) ves_det_1)
             ves_det_all (* count ves_det_1))
         )
         )
     )
;;;======= ????? ???????? (???? ??? ??????) +
   ((vl-position (car WHAT) '("-" "????" "??????" )) ;_????? ????????
     (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
     (setq L (str-str-lst L "?"))
    (setq *MPROF* (STRCAT (if (= (car WHAT) "??????") "?????? " "???? ")
                          (dwgru-string-replace (rtos (apply 'min (mapcar 'atof L)) 2 1) ".0" "")
                          ))
     (if (= (length L) 3)(setq DLN 1))
     (setq ves_det_1 (* (apply '* (mapcar 'atof L)) DLN *STAL*)
           ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
                    ves_det_all (* count ves_det_1))
     )
;;;======= ????? ???????? ??? ????????? ??????? ?
    ((vl-position (car WHAT) '("??" "FL" "??????" "\\U+0547\\U+0580\\U+057B\\U+0561\\U+0576")) ;_????? ????????
    (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
    (setq L (str-str-lst L "?"))
                      ;;;??? ????? ??? ??????? ?????????? ??? ?? ???????? ?? 0.5 ???????? ? ???????? ???????? ?? ????? ? ?? *STAL*
                      ;;;??????? - ??????? ?????, ????? - ???????
                     (setq L     (mapcar 'atof L))
                     (setq Diam  (apply 'max L) ;_ ???????
                           sH (apply 'min L) ;_ ??????
                           )
    (setq *MPROF* (STRCAT "???? " (dwgru-string-replace (rtos Sh 2 0) ".0" "")))
                      (setq ves_det_1 (* pi 0.25 Diam Diam sH *STAL*)
                            ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
                            ves_det_all (* count ves_det_1))
                    )
;;;======= ????? ??????? +
   ((vl-position (vl-string-trim  "%UuoO??Cc \t" (car WHAT)) '("????????????" "??" "TR" "TP" "T?" "?P" "?????" "\U053d\U0578\U0572." "\U053d\U0578\U0572\U0578\U057e\U0561\U056f")) ;_????? ???????
    (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
    (setq L (str-str-lst L "?"))
    ;;;??? ????? ??? ???? ?????????? ??? ?? ???????? ?? 0.5 ???????? ? ???????? ???????? ?? ????? ? ?? *STAL*
    ;;;??????? - ??????? ?????, ????? - ???????
                     (setq L (mapcar 'atof L))
                     (setq Diam (apply 'max L) ;_ ???????
                           Ts (apply 'min L) ;_ ??????? ??????
                           Diam (* 0.5 Diam)    ;_??????? ??????
                           sH (- Diam Ts)    ;_?????????? ??????
                           )
(setq *MPROF* (strcat "????? ??????? " (rtos (* 2 Diam) 2 0) "?" (rtos Ts 2 0)))                    
                      (setq ves_det_1 (*  (- (* Diam Diam)(* sH sH)) DLN pi *STAL*)
                            ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
                            ves_det_all (* count ves_det_1))
                    )
;;;======= ????? ?????????????? ?????????? ? ?????????????n ?
   ((vl-position (vl-string-trim  "%UuoO??Cc \t" (car WHAT)) '("?" "\\U+E72E" "\\U+?72?")) ;_????? ?????????????? ?????????? ? ?????????????
    (setq Vs (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
    (setq Ts (find-prokat-ves "?" Vs (if (= obzn "") naim obzn) 0))
    (if (and Ts (apply '= Ts))(setq Ts (list(car Ts)))) ;_???? ????????? ????????? ? ??? ???? ??????????
    (setq ves_det_1 (car Ts))
    (if (and Ts (numberp (car Ts))(zerop (car Ts)))(setq Errcod 0 ves_det_1 nil))
    (If ves_det_1
      (progn
        (setq *MPROF* (strcat "??????? ?????? " (MIP-CONV-TO-STR *MPROF*))
              ves_det_1 (*  ves_det_1 DLN (if (< DLN 5) 1 0.001))
              ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
              ves_det_all (* count ves_det_1)
              Errcod 0)
        )
      (progn
        (if (and Ts (numberp (car Ts))(zerop (car Ts)))(setq Errcod 0)(setq Errcod 4)) ;_??? ? ???? ??????? ?? ???????
        (setq L (str-str-lst Vs "?"))
        (setq L (mapcar 'atof L))
        (if (= (length L) 2)
          ;;;????? ??????????
          (setq Sh (apply 'max L) ;_ ??????
                Vs Sh             ;_??????
                Ts (apply 'min L) ;_ ??????? ??????
                *MPROF* "????? "
                )
          (setq Ts (apply 'min L) ;_ ??????? ??????
                Sh (apply 'max (vl-remove Ts L)) ;_ ??????
                Vs (apply 'min (vl-remove Ts L)) ;_ ??????
                *MPROF* "????? "
                )
          )
        (setq *MPROF* (strcat *MPROF* (rtos Vs 2 0) "?" (rtos Sh 2 0) "?" (rtos Ts 2 0)))
        (setq Diam (- Sh Ts Ts)  ;_ ?????? ??????????
              kF (- Vs Ts Ts)  ;_?????? ??????????
              )
        (setq ves_det_1 (*  (- (* Sh Vs)(* Diam kF)) DLN *STAL*)
              ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
              ves_det_all (* count ves_det_1))
        )
      )
    )
;;;======= ??????
   ((vl-position (vl-string-trim  "%UuoO??Cc \t" (car WHAT))
      '("?" "??????" "\\U+E720" "\\U+E721" "\\U+E722" "\\U+E723" "\\U+?720" "\\U+?721" "\\U+?722" "\\U+?723"  "L")) ;_?????? ??????? UNICOD ?? ?????? CS_Gost2304
    (if (vl-position (car WHAT) '("\\U+E721" "\\U+E722" "\\U+E723" "\\U+?721" "\\U+?722" "\\U+?723")) ;_??????? ??????
     (setq kFAll 2)
     )
    (setq L (vl-string-translate "X" "?" (car(str-str-lst (cadr what) " ")))) ;;;_ ????????  ?????????? X ?? ??????? ? ?? ? ?????? ???????? ?? ???????
    (setq L (str-str-lst L "?"))
    (setq L (mapcar 'atof L))
    (if (= (length L) 2)
      ;;;?????? ?????????????
      (setq Sh (apply 'max L) ;_ ??????
            Vs Sh             ;_??????
            Ts (apply 'min L) ;_ ??????? ??????
            )
      (setq Ts (apply 'min L) ;_ ??????? ??????
            Sh (apply 'max (vl-remove Ts L)) ;_ ??????
            Vs (apply 'min (vl-remove Ts L)) ;_ ??????
            )
      )
    (setq Diam (max Vs Sh)
          Sh (min Vs Sh)
          Vs Diam
          )
    (setq L(find-prokat-ves "?"
             (strcat
               (dwgru-string-replace (rtos Vs 2 1) ".0" "")
               "?"
               (dwgru-string-replace (rtos Sh 2 1) ".0" "")
               "?"
               (dwgru-string-replace (rtos Ts 2 1) ".0" "")
               )
              (if (= obzn "") naim obzn) 0))
    (setq *MPROF* (STRCAT "?????? " (MIP-CONV-TO-STR *MPROF*)))
    (if (and L (apply '= L))(setq L (list(car L)))) ;_???? ????????? ????????? ? ??? ???? ??????????
    (if (and L (numberp (car L))(zerop (car L)))(setq Errcod 0 L nil))
    (cond ((null L)(setq ves_det_1 0 ves_det_all 0 Errcod 1)) ;_??? ? ????
         ((> (length L) 1)(setq ves_det_1 (car L) Errcod 2)) ;_?????? ??????, ????? 1-?
         (t (setq ves_det_1 (car L)))
         )
    (setq ves_det_1   (* ves_det_1 DLN (if (< DLN 5) 1 0.001))
          ves_det_1   (if (_get_sumT_Ves1)(atof(_sumT_Ves_okr ves_det_1)) ves_det_1)
          ves_det_all (* count ves_det_1 kFAll))
    )
  (t ;;;??????????
   (setq ves_det_1 0  ves_det_all 0 Errcod 8 *MPROF* "")
   )
  );_cond
  ;(princ "\nMPROF=")(princ *MPROF*)(princ " ");(princ what)
  (list ves_det_1 ves_det_all kFAll Errcod *MPROF*)
)
(defun C:SPECW ()(specWood)(princ))
(defun C:SPEC5 ()(speckg "5")(princ))
(defun C:SPEC5D ()(speckg "5D")(princ))
(defun C:SPEC4 ()(speckg "4")(princ))
(defun C:SPEC4D ()(speckg "4D")(princ))
(defun C:SPEC3 ()(speckg "3")(princ))
(defun C:SPEC3D ()(speckg "3D")(princ))
(defun C:SPECKG ( / ret)
  (setq ret (mydcl-i "??????? ??????? ????????????. ?????????? ?????????"
                     '(
                       "5 -  ??????????? ???????????? ???-?? ?????_?? ?????_?????"         ;_ 0
                       "5D - ??????????? ???????????? ????? ???-?? ?????_?? ?????_?????"   ;_ 1
                       "4 -  ??????????? ???????????? ???-?? ?????_??"                     ;_ 2
                       "4D - ??????????? ???????????? ????? ???-?? ?????_??"               ;_ 3
                       "3 -  ??????????? ???????????? ???-??"                              ;_ 4
                       "3D - ??????????? ???????????? ????? ???-??"                        ;_ 5
                       )
                     )
        )
                       
                       
  (speckg (nth ret '("5" "5D" "4" "4D" "3" "3D")))
  (princ)
  )

(defun IsAllCharNumeric  ( str / translit)(vl-load-com)  
;;;  http://www.autocad.ru/cgi-bin/f1/board.cgi?t=28488Sx
;;;  ???????????? ???????? ????? ? translit.ru
;;;  ?? ??????? 
;;;  name - ???????? ?????? 
;;;  ???????????? ???????????????
  (apply 'and
  (mapcar '(lambda(x)
             (vl-position x '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0" "."))
             )
          (mapcar 'chr (vl-string->list (vl-string-trim  "%UuoO \t" str)))
          )
         )
)

;;;???????????? ?? ??? ???? 20-93        ??????? 25?2, l=3000       5          100
;;; tip - ??? ???????????? (???-?? ????????? ????????)
(defun SpecKG ( tip / nab pt1 pt2 i SUM okr fuzz marka dlina col ves1 vesall ind pt_ves1 pt_ves_all pat minCol *error* ved itog arm)
  (defun *ERROR*(msg)
    (princ msg)(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))(princ)); end of *ERROR*
  
(vl-load-com)
(vla-StartUndoMark  (vla-get-activedocument (vlax-get-acad-object)))
(if (and ACET-GEOM-TEXTBOX (or *PROKAT_VES_BASE* (_read-prokat-base)))
(progn  
(setq okr (_get_sumT_Okr) ved nil)
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(cond ((= tip "5")(setq minCol 4 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "5D")(setq minCol 5 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 6 ??? 5 ???????? (??? ???? ????? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "4")(setq minCol 3 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "4D")(setq minCol 4 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ????? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "3D")(setq minCol 3 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ????? ???-??). ?????? ?????: ")
       )
      (t (setq tip "3")(setq minCol 2 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 3 ??? 2 ???????? (??????????? ???????????? ????????????). ?????? ?????: ")
       )
      )
  ;(princ "??????? ?????? ??????? ?????, ?????,???-??,???1, ??? ????")
(initget 1)
(setq pt1  (getpoint))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
 (if (= tip "5D")
   (progn
     (setq nab (mapcar '(lambda(x / ost str)
           (setq ost (reverse x)
                 ost (list (cadr ost)(car ost)))
           (setq x (cddr (reverse x)))
           (setq x (mapcar '(lambda(y)(mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget y))))))) x))
            (setq x (_prepare_base x))
           (if (= (length x) 1) ;_??? ????????????
             (setq x (list "-" "-" (car x) ""))
             )
           (if (= (length x) 2) ;_????????? ??? ???????. ?????
             (progn
               (if (not(wcmatch (last x) "*????*,*??*,*???*,*???*,*???*,*??*")) ;_???????? ??????? ???????????
                 (setq x (append x '("")))
                 ;;;????? ????????? ????? ? ??????????
                 (setq x (append
                           (list "-"
                                 (if (setq str(cadr(str-str-lst (car x) "=")))
                                   str
                                   "-"
                                   )
                                 )
                           x))
                 )
               )
             )
           (cond ((= (length x) 3) ;_???????? ???? ???????. ?????
                  (if (or (wcmatch (last x) "*????*,*??*,*???*,*???*,*???*,*??*") ;_????? ???????????. ????????? ????
                          (= (last x) "")
                          )
                    (cond ((not(IsAllCharNumeric (car x))) ;_??? ??????????
                         (setq x (cons "" x))
                         )
                        ((not(cadr (str-str-lst (cadr x) "=")));_?? ?????
                         (setq x (append(list (car x) "")(cdr x)))
                         )
                        (t
                         (setq x (append(list (car x) (cadr x))(cdr x)))
                         )
                          )
                    (setq x (append x '("")));_????????? ???????????
                    )
                  )
                  (t nil)
                 );_cond
                 (append (reverse x) ost)
                          );_lambda
                       nab
                  )
           )
     )
   (setq nab (mapcar '(lambda(x)(if (= (length x) minCol)(cons nil x) x)) nab))
   );_if = tip "5D"
  (setq pt1 (apply 'min (mapcar 'length nab)))
  (setq nab (vl-remove-if-not '(lambda(x)(= (length x) pt1)) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
(setq obz  (mapcar '(lambda(x)(nth 0 x)) nab)
      marka (mapcar '(lambda(x)(nth 1 x)) nab)
      col  (mapcar '(lambda(x)(nth ind x)) nab)
      ind  (if (= ind 3) 2 1) ;_?????? ???????? ??????????? ????? 2 ??? ???? D 1 - ???????
      dlina (mapcar '(lambda(x)(nth ind x)) nab)
   )
  
(if 
      
      (and  obz marka col dlina
	 (= (length obz)
            (length marka)
            (length col)
            (length dlina)
            )
          (= (1+ minCol) pt1)  
          (apply 'and marka)
          (apply 'and col)
          (apply 'and dlina)  
	 )
    (progn
      
      
      ;;;???????? ??????? ?????????, ?????? ???????, ?????????, ?????????????, ?????????????,
      ;;;??????? ??????? ??????. ?.?. %% ???? ?????????, ?? ?? ????????, ????????? ??? %%c ???????? ?????? ?
      ;;;????? ?????????? C ?????????? ?? ??????? ?
      (setq
        table (mapcar '(lambda (a1 a2 a3 a4)
                         (list
                           (mip_mtext_unformat
                             (vl-string-translate
                               ","
                               "."
                               (vl-string-trim
                                 "%UuoO \t"
                                 (cond ((= (type a1) 'ENAME)
                                        (cdr (assoc 1 (entget a1)))
                                       )
                                       ((= (type a1) 'STR) a1)
                                       (t "")
                                 ) ;_ end of cond
                               ) ;_ end of vl-string-trim
                             ) ;_ end of vl-string-translate
                           ) ;_ end of mip_mtext_unformat
                           (if a2
                             (mip_mtext_unformat
                               (vl-string-translate
                                 ","
                                 "."
                                 (vl-string-trim
                                   "%UuoO \t"
                                   (cond ((= (type a2) 'ENAME)
                                          (cdr (assoc 1 (entget a2)))
                                         )
                                         ((= (type a2) 'STR) a2)
                                         (t "")
                                   ) ;_ end of cond
                                 ) ;_ end of vl-string-trim
                               ) ;_ end of vl-string-translate
                             ) ;_ end of mip_mtext_unformat
                             "1"
                           ) ;_ end of if
                           (mip_mtext_unformat
                             (vl-string-translate
                               ","
                               "."
                               (vl-string-trim
                                 "%UuoO \t"
                                 (cond ((= (type a3) 'ENAME)
                                        (cdr (assoc 1 (entget a3)))
                                       )
                                       ((= (type a3) 'STR) a3)
                                       (t "")
                                 ) ;_ end of cond
                               ) ;_ end of vl-string-trim
                             ) ;_ end of vl-string-translate
                           ) ;_ end of mip_mtext_unformat
                           (if a4
                             (mip_mtext_unformat
                               (vl-string-translate
                                 ","
                                 "."
                                 (vl-string-trim
                                   "%UuoO \t"
                                   (cond ((= (type a4) 'ENAME)
                                          (cdr (assoc 1 (entget a4)))
                                         )
                                         ((= (type a4) 'STR) a4)
                                         (t "")
                                   ) ;_ end of cond
                                 ) ;_ end of vl-string-trim
                               ) ;_ end of vl-string-translate
                             ) ;_ end of mip_mtext_unformat
                             "1"
                           ) ;_ end of if
                         ) ;_ end of list
                       ) ;_ end of lambda
                      obz
                      marka
                      col
                      dlina
              ) ;_ end of mapcar

      ) ;_ end of setq
 ;;???????? ?? ???? ??????? ????
 ;;; - X ????????? ?? ? ???????
 ;;; - , ?? .
 ;;; - 2 ??????? ?? 1 ??????
 ;;; -   ?????????? ??????? ????? ?? ???????
 ;;; - ????????? ??? ? ??????? ???????
   (setq table (_prepare_base table))
      ;;?????????????? ??????? ?????. ????? ??????????? ? ????? (????????????) ??? L=
      ;;???? ????? L=? ???? ??????? ? ( ? ?.?. ?? ?.?. ??), ?? ????? ????????? ? ??????, ????? - ??
      ;;???? ??? =, ?? ????????? 1 ???? (1000 ??)
      (setq dlina
             (mapcar '(lambda(x / lst ret)
                 (setq x (nth 3 x)) ;???? ?????
                 (if (IsAllCharNumeric x)(setq ret (atof x))
                   (progn
                     (setq lst (str-str-lst x "="))
                     ;(setq x (cadr lst))
                     (setq x (mip-conv-to-str (cadr lst)))
                     (if (= x "") (setq ret 1000.) ;_?????? ?? ??????? ????????? 1 ?
                       (setq ret (atof x)))
                     )
                   )
                   (if (equal ret 0.0 1e-6)(setq ret 1))
                   (setq ret (abs ret))     
                     (cond
                       ((wcmatch x "*??*") nil) ;_?????????? ???????????
                       ((or
                          (wcmatch x "*?.??*")  ;_?????????? ?????????? ?????
                          (wcmatch x "*??.?*")
                          (wcmatch x "*? ??*")
                          (wcmatch x "*?? ?*")
                          )
                        nil)
                       ((or
                          (IzPM x)
                          (wcmatch x "*# ?*") ;_ ????????????? ?? ?????, ?????? ? ?
                          )
                        (setq ret (* ret 1000.))
                        )
                        (t nil)
                        )
                        ret
                        )
              table
              )
            )
      ;;?????????????? ??????? ??????????
      ;;???? ?????????? 0, ?? ??????? 1
      (setq col
             (mapcar '(lambda(x / lst)
                 (setq x (nth 2 x)) ;???? ?????
                 (if (zerop (setq x (atof x)))
                   1
                   x
                   )
                 )
              table
              )
             )
(cond 
      ((member tip '("4" "4D"))
       (setq pt_ves1 (mapcar 'last nab)
             pt_ves_all nil)
       )
      ((member tip '("5" "5D"))
       (setq Ind (mapcar 'reverse nab)
             pt_ves_all (mapcar 'car Ind)
             pt_ves1 (mapcar 'cadr Ind))
       )
      (t
       
;;;       (initget 1)
;;;       (setq pt1  (getpoint "\n??????? ?????? ?????? \"????? ??\". ?????? ?????: "))
;;;       (initget 1)
;;;       (setq pt2  (getcorner pt1 "\n??????? ?????? ?????? \"????? ??\". ?????? ?????: "))
;;;       (setq pt_ves1 (mapcar '(lambda (x y)(* 0.5 (+ x y))) pt1 pt2))
;;;       (setq pt_ves1 (trans pt_ves1 1 0))
;;;       (if (setq pt1  (getpoint "\n??????? ?????? ?????? \"????? ????\". ?????? ????? <???????????>: "))
;;;           (progn
;;;             (initget 1)
;;;             (setq pt2  (getcorner pt1 "\n??????? ?????? ?????? \"????? ????\". ?????? ?????: "))
;;;             (setq pt_ves_all (mapcar '(lambda (x y)(* 0.5 (+ x y))) pt1 pt2))
;;;             (setq pt_ves_all (trans pt_ves_all 1 0))
;;;             )
;;;         (setq pt_ves_all nil)
;;;         )
       (initget 1)
       (setq pt_ves1  (getpoint "\n??????? ???????? ??????? \"????? ??\": "))
       (setq pt_ves1 (trans pt_ves1 1 0))
       (if (setq pt_ves_all  (getpoint "\n??????? ???????? ??????? \"????? ????\" <???????????>: "))
         (setq pt_ves_all (trans pt_ves_all 1 0))
         )
      
       (setq pt1 (entget(car marka)))
;;;?? ??????? ????? 1-? ??????? ???? ????? (????????????)
       (setq pat (list
             '(0 . "TEXT")
             (assoc 410 pt1) ;_????????????
             (assoc 8 pt1)   ;_????
             '(100 . "AcDbText")
             (assoc 10 pt1)
             (assoc 40 pt1) ;_??????
             (assoc 1 pt1)  ;_????????
             (assoc 50 pt1)  ;_???????
             '(41 . 1.0)
             (if (= (cdr(assoc 0 pt1)) "TEXT")
             (assoc 51 pt1)  ;_???? ???????
             (cons 51 (cdr(assoc 50(tblsearch "STYLE" (cdr(assoc 7 pt1))))))
               )
             (assoc 7 pt1)  ;_?????
             '(71 . 0)
             '(72 . 1) ;_????????????? ?? ??????
             (cons 11 (cdr(assoc 10 pt1))) ;_????? ????????????
             (assoc 210 pt1)  ;_???? ???????
             '(100 . "AcDbText")
             '(73 . 2);_??????????? ?? ??????
             )
       )
       )
      
      )
       (setq Ind '-1 ved nil itog nil)

 (mapcar '(lambda(line / obzn naim dln count ret pt10 ed tmp Err)
            (setq Ind (1+ Ind))
            
            ;(setq line (nth Ind table))
            (setq obzn (apply 'strcat(mapcar '(lambda(x)(strcat x "|")) line))
                  naim (cadr line)
                  dln (nth Ind dlina)
                  count (nth Ind col)
                  )
            
            (setq ret (_get_Prokat_ves obzn naim dln count))
            (setq ved (cons 
                            (list obzn
                                  *MPROF*
                                  (MIP-CONV-TO-STR(find-sortament-GOST "" obzn))
                                  (cadr ret)
                                  *PROKAT_KLASS*
                                  )
                            ved
                            )
                  )
            (setq Err (_get_Err_color_string (nth 3 ret)))

 (if (and (= (type (nth Ind pt_ves1)) 'ENAME)
          (setq tmp (_dwgru-conv-ent-to-vla (nth Ind pt_ves1)))
          (vlax-write-enabled-p tmp)
          )
   (progn
     (vla-put-TextString tmp
       (if (zerop (car ret)) "-"
           (_sumT_prep_Number(_sumT_Ves_okr (car ret))))
       )
     )
   (progn
     (setq pt1 (ACET-GEOM-TEXTBOX (entget(nth ind marka)) 1e-3))
     (setq pt2 (mapcar '(lambda (x y)(* 0.5 (+ x y)))
                       (mapcar '(lambda(x)(apply 'min x))(apply 'mapcar (cons 'list pt1)))
                       (mapcar '(lambda(x)(apply 'max x))(apply 'mapcar (cons 'list pt1)))
                       )
           )
     (setq pt10 (list (car pt_ves1)
                      (cadr pt2)
                      (caddr pt_ves1)
                      )
           )
     (setq ed (subst (cons 10 pt10)(assoc 10 pat) pat))
     (setq ed (subst (cons 11 pt10)(assoc 11 ed) ed))
     (setq ed (subst (cons 1
                           (if (zerop (car ret)) "-"
                             (_sumT_prep_Number(_sumT_Ves_okr (car ret))))
                           )
                     (assoc 1 ed) ed))
     (setq ed (entmakex ed))
     (setq tmp (_dwgru-conv-ent-to-vla ed))
     )
   )
(if (and tmp (vlax-write-enabled-p tmp))
  (progn
    (setq ves1 tmp)
    (vla-put-color tmp  (car Err))
    (mip-put-hyperlink tmp (cadr Err))
    )
  )
(setq tmp nil)            
(cond
  ((and pt_ves_all (= (type (nth Ind pt_ves_all)) 'ENAME)  ;_????? ?????
          (setq tmp (_dwgru-conv-ent-to-vla (nth Ind pt_ves_all)))
          (vlax-write-enabled-p tmp)
          )
     (vla-put-TextString tmp  (if (zerop (cadr ret)) "-" (_sumT_prep_Number(_sumT_Ves_okr (cadr ret)))))
   (mip-put-hyperlink tmp "")
   (vla-put-color tmp  (car Err))
   )
  ((and pt_ves_all (listp pt_ves_all) (apply 'and(mapcar 'numberp pt_ves_all)))
   (setq pt10 (list (car pt_ves_all)
                    (cadr pt2)
                    (caddr pt_ves_all)
                    )
         )
                (setq ed (subst (cons 10 pt10)(assoc 10 pat) pat))
                (setq ed (subst (cons 11 pt10)(assoc 11 ed) ed))
                (setq ed (subst (cons 1
                                  (if (zerop (cadr ret)) "-"
                                    (_sumT_prep_Number(_sumT_Ves_okr (cadr ret))))
                                  )
                                  (assoc 1 ed) ed))
                (setq ed (entmakex ed))
                (setq tmp (_dwgru-conv-ent-to-vla ed))
                (vla-put-color tmp  (car Err))
   )
  (t  (setq tmp ves1);_????? ? ???1
   )
  );_cond
(if (and tmp
         (vlax-write-enabled-p tmp)
         )
     (progn
       (if (= (cadr Err) "")
         
         (mip-put-hyperlink tmp (strcat (_sumT_Ves_okr (cadr ret))
                                                    "="
                                                    (_sumT_Ves_okr (car ret))
                                                    " * "
                                                    (rtos count 2 1)
                                                    (if (= (nth 2 ret) 1)
                                                      ""
                                                      (strcat " * " (itoa (nth 2 ret)))
                                                      )
                                                  )
                        )
                  )
                )
              )            
   )
         table
         )
      (setq arm  (last(assoc "?????????????" *PROKAT_VES_BASE*))) ;_?????? ????????

      (mapcar '(lambda(line / pt1 pt2 nab diam gost klass ed tmp ret obzn)
               (setq obzn (car line) line (cdr line))
(setq klass (mip-conv-to-str
                              (car
                              (vl-remove-if 'null
                              (mapcar '(lambda(x)
                                   (if (wcmatch obzn (strcat "*" x "*"))
                                       ;(vl-string-search x obzn)
                                     x
                                     nil
                                     )
                                   )
                                arm
                                )
                                )
                              )
                              )
                            
                  )
            (if (= klass "")(setq klass (strcat "?????? " (mip-conv-to-str(nth 3 line))))
              (setq klass (strcat "???????? " klass)))
            (setq diam (car line))
            (setq GOST (cadr line)) 
            (setq ret (cdr line))
            (if (setq tmp (assoc klass itog))
              (progn
                (setq ed (cdr tmp))
                (if (setq pt1 (assoc GOST ed))
                  (progn
                    (setq pt2 (cdr pt1))
                    (if (setq nab(assoc diam pt2))
                      (setq pt2
                             (subst (list (car nab)(+ (cadr nab)(cadr ret)))
                             (assoc diam pt2)
                             pt2)
                            )
                      
                      (setq pt2 (cons (list diam (cadr ret)) pt2))
                      )
                      (setq ed (subst (cons GOST pt2)
                                       (assoc GOST ed)
                                       ed
                                       )
                            )
                                       
                    )
                  (progn
                   (setq ed (cons (list GOST (list diam (cadr ret))) ed))
                    )
                  )
                (setq itog (subst (cons klass ed)
                                      (assoc klass itog)
                                      itog
                                      )
                          )
                
                )
              (setq itog (cons
                           (list klass (list GOST (list diam (cadr ret))))
                           itog)
                    );_setq
                 
                 )
                 )
              ved
              
      )
      (setq ved nil)
    (setq itog  
    (mapcar '(lambda (kl)
               (cons (car kl)
                     (mapcar '(lambda(GST / sort_list) ;!!23456
                                (setq sort_list (SortstringWithNumberasNumber (mapcar 'car (cdr GST)) nil))
                                (cons (car GST)
                                      (vl-sort (cdr GST)
                                               '(lambda (a1 a2)
                                                  (< (VL-POSITION (car a1) sort_list)
                                                     (VL-POSITION (car a2) sort_list)
                                                     )
                                                  )
                                               )
                                      )
                               )
                             (cdr KL)
                             )
                     )
               )
            itog)
          )
;;;      (setq iii itog)
;;;      (setq itog iii)
      (princ "\n============= ???? ?????? ==============\n")
      (foreach klass itog
        (princ "\n????? : ")(princ (car klass))
      (mapcar '(lambda(line)
                 (terpri)
                 (princ (car line))
                 (foreach xx (cdr line)
                   (princ "\n     ")
                   (princ (car xx))
                   (princ "  -  ")
                   (princ (cadr xx))
                   (princ " ??.")
                   )
                 (princ "\n-------------------------------------------------")
                 )
              (cdr klass)
              )
        )
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
)
 (if (null ACET-GEOM-TEXTBOX )(alert "?????????? ????????? Express Tools!"))
  )
  
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
(princ)
)

;;;???????????? ??????
;;; ??????? B H L ???-?? ????? ??, ????? ?????
(defun SpecWood ( / nab pt1 pt2 i SUM okr fuzz marka dlina col ves1 vesall ind pt_ves1 pt_ves_all pat minCol *error* ved itog tip)
  (defun *ERROR*(msg)
    (princ msg)(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))(princ)); end of *ERROR*
  
(vl-load-com)
(vla-StartUndoMark  (vla-get-activedocument (vlax-get-acad-object)))
(if (and ACET-GEOM-TEXTBOX (or *PROKAT_VES_BASE* (_read-prokat-base)))
(progn
(setq tip "5D")  
(setq okr (_get_sumT_Okr) ved nil)
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(cond ((= tip "5")(setq minCol 4 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "5D")(setq minCol 6 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 6 ???????? (B H L ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "4")(setq minCol 3 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "4D")(setq minCol 4 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ????? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "3D")(setq minCol 3 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ????? ???-??). ?????? ?????: ")
       )
      (t (setq tip "3")(setq minCol 2 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 3 ??? 2 ???????? (??????????? ???????????? ????????????). ?????? ?????: ")
       )
      )
  ;(princ "??????? ?????? ??????? ?????, ?????,???-??,???1, ??? ????")
(initget 1)
(setq pt1  (getpoint))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
  ;(setq nab (mapcar '(lambda(x)(if (= (length x) minCol)(cons nil x) x)) nab))
  (setq pt1 (apply 'max (mapcar 'length nab)))
  ;(setq nab (vl-remove-if-not '(lambda(x)(= (length x) pt1)) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
(setq obz  (mapcar '(lambda(x)(nth 0 x)) nab)
      marka (mapcar '(lambda(x)(nth 1 x)) nab)
      dlina  (mapcar '(lambda(x)(nth 2 x)) nab)
      col  (mapcar '(lambda(x)(nth 3 x)) nab)
   )
  
(if 
      
      (and  obz marka col dlina
	 (= (length obz)
            (length marka)
            (length col)
            (length dlina)
            )
            (= pt1 6)
          
	 )
    (progn
      
      ;;;???????? ??????? ?????????, ?????? ???????, ?????????, ?????????????, ?????????????,
      ;;;??????? ??????? ??????. ?.?. %% ???? ?????????, ?? ?? ????????, ????????? ??? %%c ???????? ?????? ?
      ;;;????? ?????????? C ?????????? ?? ??????? ?
      (setq table (mapcar '(lambda(a1 a2 a3 a4)
                             (list
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (if a1 (cdr(assoc 1 (entget a1))) ""))))
                               (if a2
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a2))))))
                                 "1"
                                 )
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a3))))))
                             (if a4
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a4))))))
                                 "1"
                                 )
                               )
                          )
                          obz marka col dlina
                          )
            
            )
 ;;???????? ?? ???? ??????? ????
 ;;; - X ????????? ?? ? ???????
 ;;; - , ?? .
 ;;; - 2 ??????? ?? 1 ??????
 ;;; -   ?????????? ??????? ????? ?? ???????
 ;;; - ????????? ??? ? ??????? ???????
   (setq table (_prepare_base table))
      ;;?????????????? ??????? ?????. ????? ??????????? ? ????? (????????????) ??? L=
      ;;???? ????? L=? ???? ??????? ? ( ? ?.?. ?? ?.?. ??), ?? ????? ????????? ? ??????, ????? - ??
      ;;???? ??? =, ?? ????????? 1 ???? (1000 ??)
      (setq dlina
             (mapcar '(lambda(x / lst ret)
                 (setq x (nth 3 x)) ;???? ?????
                 (if (IsAllCharNumeric x)(setq ret (atof x))
                   (progn
                     (setq lst (str-str-lst x "="))
                     ;(setq x (cadr lst))
                     (setq x (mip-conv-to-str (cadr lst)))
                     (if (= x "") (setq ret 1000.) ;_?????? ?? ??????? ????????? 1 ?
                       (setq ret (atof x)))
                     )
                   )
                   (if (equal ret 0.0 1e-6)(setq ret 1))
                   (setq ret (abs ret))     
                     (cond
                       ((wcmatch x "*??*") nil) ;_?????????? ???????????
                       ((or
                          (wcmatch x "*?.??*")  ;_?????????? ?????????? ?????
                          (wcmatch x "*??.?*")
                          (wcmatch x "*? ??*")
                          (wcmatch x "*?? ?*")
                          )
                        nil)
                       ((or
                          (IzPM x)
                          (wcmatch x "*# ?*") ;_ ????????????? ?? ?????, ?????? ? ?
                          )
                        (setq ret (* ret 1000.))
                        )
                        (t nil)
                        )
                        ret
                        )
              table
              )
            )
      ;;?????????????? ??????? ??????????
      ;;???? ?????????? 0, ?? ??????? 1
      (setq col
             (mapcar '(lambda(x / lst)
                 (setq x (nth 2 x)) ;???? ?????
                 (if (zerop (setq x (atof x)))
                   1
                   x
                   )
                 )
              table
              )
             )
(cond 
      ((member tip '("4" "4D"))
       (setq pt_ves1 (mapcar 'last nab)
             pt_ves_all nil)
       )
      ((member tip '("5" "5D"))
       (setq Ind (mapcar 'reverse nab)
             pt_ves_all (mapcar 'car Ind)
             pt_ves1 (mapcar 'cadr Ind))
       )
      (t
       
;;;       (initget 1)
;;;       (setq pt1  (getpoint "\n??????? ?????? ?????? \"????? ??\". ?????? ?????: "))
;;;       (initget 1)
;;;       (setq pt2  (getcorner pt1 "\n??????? ?????? ?????? \"????? ??\". ?????? ?????: "))
;;;       (setq pt_ves1 (mapcar '(lambda (x y)(* 0.5 (+ x y))) pt1 pt2))
;;;       (setq pt_ves1 (trans pt_ves1 1 0))
;;;       (if (setq pt1  (getpoint "\n??????? ?????? ?????? \"????? ????\". ?????? ????? <???????????>: "))
;;;           (progn
;;;             (initget 1)
;;;             (setq pt2  (getcorner pt1 "\n??????? ?????? ?????? \"????? ????\". ?????? ?????: "))
;;;             (setq pt_ves_all (mapcar '(lambda (x y)(* 0.5 (+ x y))) pt1 pt2))
;;;             (setq pt_ves_all (trans pt_ves_all 1 0))
;;;             )
;;;         (setq pt_ves_all nil)
;;;         )
       (initget 1)
       (setq pt_ves1  (getpoint "\n??????? ???????? ??????? \"????? ??\": "))
       (setq pt_ves1 (trans pt_ves1 1 0))
       (if (setq pt_ves_all  (getpoint "\n??????? ???????? ??????? \"????? ????\" <???????????>: "))
         (setq pt_ves_all (trans pt_ves_all 1 0))
         )
      
       (setq pt1 (entget(car marka)))
;;;?? ??????? ????? 1-? ??????? ???? ????? (????????????)
       (setq pat (list
             '(0 . "TEXT")
             (assoc 410 pt1) ;_????????????
             (assoc 8 pt1)   ;_????
             '(100 . "AcDbText")
             (assoc 10 pt1)
             (assoc 40 pt1) ;_??????
             (assoc 1 pt1)  ;_????????
             (assoc 50 pt1)  ;_???????
             '(41 . 1.0)
             (if (= (cdr(assoc 0 pt1)) "TEXT")
             (assoc 51 pt1)  ;_???? ???????
             (cons 51 (cdr(assoc 50(tblsearch "STYLE" (cdr(assoc 7 pt1))))))
               )
             (assoc 7 pt1)  ;_?????
             '(71 . 0)
             '(72 . 1) ;_????????????? ?? ??????
             (cons 11 (cdr(assoc 10 pt1))) ;_????? ????????????
             (assoc 210 pt1)  ;_???? ???????
             '(100 . "AcDbText")
             '(73 . 2);_??????????? ?? ??????
             )
       )
       )
      
      )
       (setq Ind '-1)
 (mapcar '(lambda(line / obzn naim dln count ret pt10 ed tmp Err V1 V_all)
            (setq Ind (1+ Ind))
            
            ;(setq line (nth Ind table))
            (setq obzn (atof (nth 0 line))
                  naim (atof (nth 1 line))
                  dln (nth Ind dlina)
                  count (nth Ind col)
                  V1 (* obzn naim dln 1e-9))
            (setq 
                  V1 (if (_get_sumT_Ves1)(atof(rtos V1 2 (_get_sumT_Okr))) V1)
                  V_all (* V1 count)
                  )
            
            (setq ret (list V1 V_all))
                        


 (if (and (= (type (nth Ind pt_ves1)) 'ENAME)
          (setq tmp (_dwgru-conv-ent-to-vla (nth Ind pt_ves1)))
          (vlax-write-enabled-p tmp)
          )
   (progn
     (vla-put-TextString tmp
       (if (zerop (car ret)) "-"
           (_sumT_prep_Number(rtos (car ret) 2 okr)))
       )
     )
    )
(if (and pt_ves_all (= (type (nth Ind pt_ves_all)) 'ENAME)  ;_????? ?????
          (setq tmp (_dwgru-conv-ent-to-vla (nth Ind pt_ves_all)))
          (vlax-write-enabled-p tmp)
          )
  (progn
    (vla-put-TextString tmp  (if (zerop (cadr ret)) "-" (_sumT_prep_Number(rtos (cadr ret) 2 okr))))
    )
  )
   )
         table
         )
      
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
)
 (if (null ACET-GEOM-TEXTBOX )(alert "?????????? ????????? Express Tools!"))
  )
  
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
(princ)
)

;|

(defun SpecDiam ( / nab pt1 pt2 i SUM okr fuzz marka dlina col ves1 vesall ind pt_ves1 pt_ves_all pat minCol *error* arm itog)
  (defun *ERROR*(msg)
    (princ msg)(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))(princ)); end of *ERROR*
(vl-load-com)  
(setq arm  (last(assoc "?????????????" *PROKAT_VES_BASE*))) ;_?????? ????????
(vla-StartUndoMark  (vla-get-activedocument (vlax-get-acad-object)))
(if (and ACET-GEOM-TEXTBOX (or *PROKAT_VES_BASE* (_read-prokat-base)))
(progn  
(setq okr (_get_sumT_Okr))
(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(setq tip "3")
(cond ((= tip "5")(setq minCol 4 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "5D")(setq minCol 5 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 6 ??? 5 ???????? (??? ???? ????? ???-?? ?????_?? ?????_????). ?????? ?????: ")
       )
      ((= tip "4")(setq minCol 3 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "4D")(setq minCol 4 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 5 ??? 4 ???????? (??? ???? ????? ???-?? ?????_??). ?????? ?????: ")
       )
      ((= tip "3D")(setq minCol 3 ind 3) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 4 ??? 3 ???????? (??? ???? ????? ???-??). ?????? ?????: ")
       )
      (t (setq tip "3")(setq minCol 2 ind 2) ;_min ??????????? ???-?? ????????.
       (princ " ??????? ?????? ??????? ?? 3 ??? 2 ???????? (??????????? ???????????? ????????????). ?????? ?????: ")
       )
      )
  ;(princ "??????? ?????? ??????? ?????, ?????,???-??,???1, ??? ????")
(initget 1)
(setq pt1  (getpoint))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
  (setq nab (mapcar '(lambda(x)(if (= (length x) minCol)(cons nil x) x)) nab))
  (setq pt1 (apply 'max (mapcar 'length nab)))
  (setq nab (vl-remove-if-not '(lambda(x)(= (length x) pt1)) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
(setq obz  (mapcar '(lambda(x)(nth 0 x)) nab)
      marka (mapcar '(lambda(x)(nth 1 x)) nab)
      col  (mapcar '(lambda(x)(nth ind x)) nab)
      ind  (if (= ind 3) 2 1) ;_?????? ???????? ??????????? ????? 2 ??? ???? D 1 - ???????
      dlina (mapcar '(lambda(x)(nth ind x)) nab)
   )
  
(if 
      ;;;4 ????????
      (and  obz marka col dlina
	 (= (length obz)
            (length marka)
            (length col)
            (length dlina)
            )
          (= (1+ minCol) pt1)  
          (apply 'and marka)
          (apply 'and col)
          (apply 'and dlina)  
	 )
    (progn
      
      ;;;???????? ??????? ?????????, ?????? ???????, ?????????, ?????????????, ?????????????,
      ;;;??????? ??????? ??????. ?.?. %% ???? ?????????, ?? ?? ????????, ????????? ??? %%c ???????? ?????? ?
      ;;;????? ?????????? C ?????????? ?? ??????? ?
      (setq table (mapcar '(lambda(a1 a2 a3 a4)
                             (list
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (if a1 (cdr(assoc 1 (entget a1))) ""))))
                               (if a2
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a2))))))
                                 "1"
                                 )
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a3))))))
                             (if a4
                               (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (cdr(assoc 1 (entget a4))))))
                                 "1"
                                 )
                               )
                          )
                          obz marka col dlina
                          )
            
            )
 ;;???????? ?? ???? ??????? ????
 ;;; - X ????????? ?? ? ???????
 ;;; - , ?? .
 ;;; - 2 ??????? ?? 1 ??????
 ;;; -   ?????????? ??????? ????? ?? ???????
 ;;; - ????????? ??? ? ??????? ???????
   (setq table (_prepare_base table))
      ;;?????????????? ??????? ?????. ????? ??????????? ? ????? (????????????) ??? L=
      ;;???? ????? L=? ???? ??????? ? ( ? ?.?. ?? ?.?. ??), ?? ????? ????????? ? ??????, ????? - ??
      ;;???? ??? =, ?? ????????? 1 ???? (1000 ??)
      (setq dlina
             (mapcar '(lambda(x / lst ret)
                 (setq x (nth 3 x)) ;???? ?????
                 (if (IsAllCharNumeric x)(setq ret (atof x))
                   (progn
                     (setq lst (str-str-lst x "="))
                     (setq x (cadr lst))
                     (if (null x) (setq ret 1000.)
                       (if (and
                             (not (wcmatch x "*??*"))
                             (wcmatch x "*?*")
                             )
                         (setq ret (* (atof x) 1000.))
                         (setq ret (atof x))
                         )
                       )
                     )
                   )
                        ret
                        )
              table
              )
            )
      ;;?????????????? ??????? ??????????
      ;;???? ?????????? 0, ?? ??????? 1
      (setq col
             (mapcar '(lambda(x / lst)
                 (setq x (nth 2 x)) ;???? ?????
                 (if (zerop (setq x (atof x)))
                   1
                   x
                   )
                 )
              table
              )
             )
(setq table (mapcar '(lambda(x)(list (car x)(cadr x))) table))      
(setq table (vl-remove-if-not '(lambda(x)
              (= (_GET_PROKAT_TIP (apply 'strcat(mapcar '(lambda(x)(strcat x "|")) x))) "?")
                                 )
              table)
      )
  (setq Ind '-1 itog nil)
 (mapcar '(lambda(line / obzn naim dln count ret pt10 ed tmp Err diam GOST)
            (setq Ind (1+ Ind))
            
            ;(setq line (nth Ind table))
            (setq obzn (apply 'strcat(mapcar '(lambda(x)(strcat x "|")) line))
                  naim (cadr line)
                  dln (nth Ind dlina)
                  count (nth Ind col)
                  )
            
            (setq ret (_get_Prokat_ves obzn  naim dln count))
            (setq diam (atoi(mip-conv-to-str(cadr(mark_parser naim)))))
            (setq GOST (find-sortament-GOST "?" obzn)) 
            (setq klass (mip-conv-to-str
                              (car
                              (vl-remove-if 'null
                              (mapcar '(lambda(x)
                                   (if (wcmatch obzn (strcat "*" x "*"))
                                     x
                                     nil
                                     )
                                   )
                                arm
                                )
                                )
                              )
                              )
                            
                  )
            (if (setq tmp (assoc klass itog))
              (progn
                (setq ed (cdr tmp))
                (if (setq pt1 (assoc GOST ed))
                  (progn
                    (setq pt2 (cdr pt1))
                    (if (setq nab(assoc diam pt2))
                      (setq pt2
                             (subst (list (car nab)(+ (cadr nab)(cadr ret)))
                             (assoc diam pt2)
                             pt2)
                            )
                      
                      (setq pt2 (cons (list diam (cadr ret)) pt2))
                      )
                      (setq ed (subst (cons GOST pt2)
                                       (assoc GOST ed)
                                       ed
                                       )
                            )
                                       
                    )
                  (progn
                   (setq ed (cons (list GOST (list diam (cadr ret))) ed))
                    )
                  )
                (setq itog (subst (cons klass ed)
                                      (assoc klass itog)
                                      itog
                                      )
                          )
                
                )
              (setq itog (cons
                           (list klass (list GOST (list diam (cadr ret))))
                           itog)
                    );_setq
              )



   )
         table
         )
      )
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
)
 (if (null ACET-GEOM-TEXTBOX )(alert "?????????? ????????? Express Tools!"))
  )
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
(princ itog)(princ)
)

|;

;|
(defun SpecGOST ( tip / nab pt1 pt2 i SUM okr fuzz marka dlina col ves1 vesall ind pt_ves1 pt_ves_all pat minCol *error*)
  (defun *ERROR*(msg)
    (princ msg)(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))(princ)); end of *ERROR*
  
(vl-load-com)
(vla-StartUndoMark  (vla-get-activedocument (vlax-get-acad-object)))
(if (and ACET-GEOM-TEXTBOX (or *PROKAT_VES_BASE* (_read-prokat-base)))
(progn  
(setq okr (_get_sumT_Okr))

(princ "\n(?????????? ?? ")(princ okr)(princ ") ")
(princ " ??????? ?????? ??????? ????????????. ???????????(????????????) - ?????_????). ?????? ?????: ")
(initget 1)
(setq pt1  (getpoint))
(initget 1)  
(setq pt2  (getcorner pt1 "\n?????? ?????: "))
(setq nab (ssget "_C" pt1 pt2 '((0 . "*TEXT"))))
(setq pt2 (_dwgru-conv-pickset-to-list nab))
(setq pt1 (mapcar '(lambda(x)(cdr(assoc 40 (entget x)))) pt2))
(setq fuzz (/ (apply '+ pt1)(length pt1)))
(setq nab
                 (combine pt2
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
			     (or (< (cadr a)(cadr b)) ;_ on Y
				 (equal (cadr a)
					(cadr b)
					  fuzz
					  )
				 ) ;_ end of or
                           ) ;_ end of lambda
                          '(lambda (x y / a b)
			     (setq a (cdr(assoc 10 (entget x))))
			     (setq b (cdr(assoc 10 (entget y))))
                             (equal (cadr a)
					(cadr b)
					  fuzz
					  )
                             ;(< (car a)(car b)) ;_ end of <
                           ) ;_ end of lambda
                 ) ;_ end of combine
          ) ;_ end of setq
  (setq nab (mapcar '(lambda(x)(vl-sort x '(lambda(a b)(< (cadr(assoc 10 (entget a)))(cadr(assoc 10 (entget b))))))) nab))
  ;(setq nab (mapcar '(lambda(x)(if (= (length x) minCol)(cons nil x) x)) nab))
  ;(setq pt1 (apply 'max (mapcar 'length nab)))
  ;(setq nab (vl-remove-if-not '(lambda(x)(= (length x) pt1)) nab))
;;(mapcar '(lambda(y)(mapcar '(lambda(x)(cdr(assoc 1 (entget x)))) y)) nab)
;;;(setq obz  (mapcar '(lambda(x)(nth 0 x)) nab)
;;;      marka (mapcar '(lambda(x)(nth 1 x)) nab)
;;;      col  (mapcar '(lambda(x)(nth ind x)) nab)
;;;      ind  (if (= ind 3) 2 1) ;_?????? ???????? ??????????? ????? 2 ??? ???? D 1 - ???????
;;;      dlina (mapcar '(lambda(x)(nth ind x)) nab)
;;;   )
  
(if nab
    (progn
      ;;;???????? ??????? ?????????, ?????? ???????, ?????????, ?????????????, ?????????????,
      ;;;??????? ??????? ??????. ?.?. %% ???? ?????????, ?? ?? ????????, ????????? ??? %%c ???????? ?????? ?
      ;;;????? ?????????? C ?????????? ?? ??????? ?
      (setq table (mapcar '(lambda(a1 / ll)
                             (setq ll (mapcar '(lambda(x)
                                                 (mip_mtext_unformat
                               (vl-string-translate "," "."
                                 (vl-string-trim  "%UuoO \t" (if x (cdr(assoc 1 (entget x))) ""))))
                                                 )
                                              a1
                                              )
                                   
                                   )
                             (list
                             (apply 'strcat(mapcar '(lambda(x)(strcat x "|")) ll))
                             (nth 1 ll)
                             (atof (last ll))
                             )
                          )
                          nab
                          )
            
            )
      
 ;;???????? ?? ???? ??????? ????
 ;;; - X ????????? ?? ? ???????
 ;;; - , ?? .
 ;;; - 2 ??????? ?? 1 ??????
 ;;; -   ?????????? ??????? ????? ?? ???????
 ;;; - ????????? ??? ? ??????? ???????
   (setq table (_prepare_base table))
    (setq Ind '-1 itog nil)
 (mapcar '(lambda(line / obzn naim dln count ret pt10 ed tmp Err tip GOST)
            (setq Ind (1+ Ind))
            
            ;(setq line (nth Ind table))
            (setq obzn (car line)
                  naim (cadr line)
                  )
            (setq tip (_get_Prokat_TIP obzn))
            (setq GOST (find-sortament-GOST tip obzn))
            (setq ret (_get_Prokat_ves obzn naim 1000 1))
           
            
            
            (setq klass (mip-conv-to-str
                              (car
                              (vl-remove-if 'null
                              (mapcar '(lambda(x)
                                   (if (wcmatch obzn (strcat "*" x "*"))
                                     x
                                     nil
                                     )
                                   )
                                arm
                                )
                                )
                              )
                              )
                            
                  )
            (if (setq tmp (assoc klass itog))
              (progn
                (setq ed (cdr tmp))
                (if (setq pt1 (assoc GOST ed))
                  (progn
                    (setq pt2 (cdr pt1))
                    (if (setq nab(assoc diam pt2))
                      (setq pt2
                             (subst (list (car nab)(+ (cadr nab)(cadr ret)))
                             (assoc diam pt2)
                             pt2)
                            )
                      
                      (setq pt2 (cons (list diam (cadr ret)) pt2))
                      )
                      (setq ed (subst (cons GOST pt2)
                                       (assoc GOST ed)
                                       ed
                                       )
                            )
                                       
                    )
                  (progn
                   (setq ed (cons (list GOST (list diam (cadr ret))) ed))
                    )
                  )
                (setq itog (subst (cons klass ed)
                                      (assoc klass itog)
                                      itog
                                      )
                          )
                
                )
              (setq itog (cons
                           (list klass (list GOST (list diam (cadr ret))))
                           itog)
                    )
              )



   )
         table
         )
 
 
      );_progn if nab
      (alert "?? ????????? ???-?? ?????? ? ????????!")
  )
)
 (if (null ACET-GEOM-TEXTBOX )(alert "?????????? ????????? Express Tools!"))
  )
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
(princ)
)
|;


;;??????? ???????? ? ??????? ???? X ????????? ?? ? ??????? , ?? . 2 ??????? ?? 1 ??????
;;?????????? ??????? ????? ?? ???????
(defun _prepare_base ( lin / ch en->rus)
(setq en->rus '(("A" "?" )("B" "?")("E" "?")("T" "?")
                ("Y" "?")("O" "?")("P" "?")("H" "?")
                ("K" "?")("X" "?")("C" "?")("M" "?"))
      )
  (cond
     ((null lin) nil)
     ((listp lin) (mapcar '_prepare_base lin))
     ((= (type lin) 'STR)
      (setq ch (strcase(vl-string-translate ",xX??" ".????"
                                 (vl-string-trim  "%UuoO \t" lin))))
      ;;; ???????? ? ?????? ??? ??????? ??????? ?? ?????????
       (setq ch (dwgru-string-replace ch (strcat (chr 32) (chr 32))(chr 32)))
      ;;; ???????? ??? ????? ?? ????
      (setq ch (dwgru-string-replace ch ".." "."))
      ;;;???????? ?????????? ????? ?? ??????? (???????)
      (setq ch (apply 'strcat
                      (mapcar '(lambda (x / sym)
                                 (if (setq sym (assoc x en->rus))
                                   (cadr sym)
                                   x
                                   ) ;_ ????? if
                                 ) ;_ ????? lambda
                              (mapcar 'chr (vl-string->list ch))
                              ) ;_ ????? mapcar
                      ) ;_ ????? apply
            )
      )
     (t lin)
   )   
  )

;;;?????? ????
(defun _read-prokat-base ( / fil fl)
  (setq fil "prokat.ves" *PROKAT_VES_BASE* nil)
  (if (setq fl (findfile fil))
    (progn
      (setq fil (open fl "r"))
      (while (setq str (read-line fil))
        
        (setq str (vl-string-trim  "%UuoO??Cc \t" str))
        (cond ((vl-position (substr str 1 1) '(";" "")) nil)
              (t
               (setq *PROKAT_VES_BASE*  (cons (read str) *PROKAT_VES_BASE* ))
               )
        )
        )
      (close fil)
      (setq *PROKAT_VES_BASE* (mapcar '_prepare_base *PROKAT_VES_BASE*))
      )
    (alert (strcat "?????????? ????? ???? ????\n" fil))
    )
  )
(defun _get_sumT_Okr ( / okr )
  (or (setq okr *sumT_Okr*)
      (setq okr (getcfg "AppData/sumT/sumT_Okr"))
      (setq okr (getvar "LUPREC"))
      )
(if (= (type okr) 'STR)(setq okr (atoi okr)))
(setq *sumT_Okr* (if (numberp okr)(fix okr) 2))
  )
(defun _get_sumT_Ves1 ( / okr )
  (or (setq okr *sumT_Ves1*)
      (if (setq okr (getcfg "AppData/sumT/sumT_Ves1"))
        (setq okr (atoi okr))
        (setq okr 1)
        )
      )
  (= okr 1)
  )

(defun _get_sumT_TH ( / okr )
  (or (setq okr *sumT_TH*)
      (setq okr (getcfg "AppData/sumT/sumT_TH"))
      (setq okr (getvar "TEXTSIZE"))
      
      )
  (cond
    ((= okr "")(setq okr (getvar "TEXTSIZE")))
    ((= (type okr) 'STR)(setq okr (atof okr)))
    ((numberp okr) okr)
    (t (setq okr (getvar "TEXTSIZE")))
    )
  (cond ((zerop okr)(setq okr (getvar "TEXTSIZE")))
	((minusp okr)(setq okr '-1))
	(t nil)
	)
  (setq *sumT_TH*  okr)
  )
(defun _sumT_prep_Number ( str )
  (vl-string-translate "." (_get_sumT_sDecimal)(mip-conv-to-str str))
  )
;;;(vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
(defun _get_sumT_sDecimal ( / okr )
  (or (setq okr *sumT_sDecimal*)
      (setq okr (getcfg "AppData/sumT/sumT_sDecimal"))
      (setq okr (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal"))
      )
  (if (= okr "")(setq okr (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")))
  (if (not (member okr '("." ",")))(setq okr ","))
  (setq *sumT_sDecimal*  okr)
  )


(defun C:sumTSet ( / okr )
  (if (or (null (setq okr (getcfg "AppData/sumT/sumT_Okr")))
	  (= okr "")
	  )
    (setcfg "AppData/sumT/sumT_Okr" "2")
    ;(setq *sumT_Okr* (atoi okr))
    )
  (or *sumT_Okr*
  (setq *sumT_Okr* (atoi(getcfg "AppData/sumT/sumT_Okr")))
      )
  (setq okr *sumT_Okr*)
  (princ "\n?????????? ?????? ?????????? <")
  (princ okr)(princ " >:")
  (initget 4)
  (if (setq okr (getint))
    (setcfg "AppData/sumT/sumT_Okr" (itoa (setq *sumT_Okr* okr)))
    (setq okr *sumT_Okr*)
    )
;;=======================================
  (if (or (null (setq okr (getcfg "AppData/sumT/sumT_Ves1")))
	  (= okr "")
	  )
    (setcfg "AppData/sumT/sumT_Ves1" "1")
    ;(setq *sumT_Okr* (atoi okr))
    )
  (or *sumT_Ves1*
  (setq *sumT_Ves1* (atoi(getcfg "AppData/sumT/sumT_Ves1")))
      )
  (setq okr *sumT_Ves1*)
  (princ "\n????????? ??? ??????? ????? ????? ????? ??????? ?? ????????????? ?????? ??????????? [??/???]<")
  (princ (if (= okr 1) "??" "???"))(princ ">:")
  (initget "?? ??? Yes No _Yes No Yes No")
  (setq okr (getkword))
  (cond ((= okr "Yes")(setq okr 1))
        ((= okr "No")(setq okr 0))
        (t (setq okr *sumT_Ves1*))
        )
    (setcfg "AppData/sumT/sumT_Ves1" (itoa (setq *sumT_Ves1* okr)))
;;=======================================
  
    (if (or (null (setq okr (getcfg "AppData/sumT/sumT_TH")))
	  (= okr "")
	  )
    (setcfg "AppData/sumT/sumT_TH" "2")
    ;(setq *sumT_Okr* (atoi okr))
    )
  (or *sumT_TH*
  (setq *sumT_TH* (atoi(getcfg "AppData/sumT/sumT_TH")))
      )
  (setq okr *sumT_TH*)
  (cond ((zerop okr)(setq okr (strcat "???????-" (rtos (getvar "TEXTSIZE") 2 2))))
	((minusp okr)(setq okr "??? ? ?????????"))
	(t nil)
	)
  (princ "\n?????? ????? ??????? ??? [???????/??? ? ?????????] <")
  (princ okr)(princ " >:")
  (initget "? ? C S _C S C S")
  (setq okr (getint))
  (cond ((= okr "C")(setq okr "0"))
	((= okr "S")(setq okr "-1"))
	((numberp okr)(setq okr (rtos okr 2 4)))
	(t (setq okr "2"))
	)
  (setcfg "AppData/sumT/sumT_TH" okr)
  (setq *sumT_TH* (atof okr))
(setq okr (getcfg "AppData/sumT/sumT_sDecimal"))  
(initget "Point Comma System ????? ??????? ????????? _Point Comma System Point Comma System")
(princ "\n??????????? ????? ? ??????? ????? [?????/???????/?????????] <")
(princ (cond ((= okr ".") "?????")
             ((= okr ",") "???????")
             (t "?????????")
             )
       )
  (princ ">: ")
  (setq okr (getkword))
(cond
  ((= okr "Point")(setq okr "."))
  ((= okr "Comma")(setq okr ","))
  (t (setq okr ""))
  )
(setcfg "AppData/sumT/sumT_sDecimal" okr)
 (_get_sumT_sDecimal) 
  
  (princ)
  )
;;;(defun C:HYPD ( / sset hyptxt)(vl-load-com)  
;;;(setq hyptxt "")
;;;(princ "\n???????? ??????? ??? ???????? ???????????")  
;;;(if (setq sset (ssget "_:L"))
;;; (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))) 
;;;   (mip-put-hyperlink item hyptxt)))(princ))
(princ "\n????????????: http:////dwg.ru//f//showthread.php?t=16987 ??????(????) #449")
(princ "\n???????? ? ????????? ??????")
(princ "\nSumTN - ???????????? ?????? ? ????? ?????")
(princ "\nSumTE - ???????????? ?????? ? ???????????? ?????")
(princ "\nMulTN - ????????? ?????? ? ????? ?????")
(princ "\nMulTE - ????????? ?????? ? ???????????? ?????")
(princ "\nTOKR  - ?????????? ??????")
(princ "\nMulTC - ???????????? ??????? ?????????")
(princ "\nMulTCv2 - ???????????? ??????? ????????? ??????? 2")
(princ "\nsumTSet - ????????? ?????????? ? ?????? ????? ???????")
(princ "\nGSUM - ??????? ????????? ????????????")
(princ "\nSPECKG - ??????? ???????????? (SPEC3 SPEC3D SPEC4 SPEC4D SPEC5 SPEC5D")
(princ "\nSPECW - ??????? ???????????? ?????????? ??????? (SPEC Wood")
(princ "\n_-HYPERLINK - ???????? ??????????? (????? _Remove)")


(princ)


;| ???????? ??????  ? ?????????? ?????
(defun rec-pat (str / rec-pat)
  (defun rec-pat (temp str pat n /)
    (cond ((= str "") (list temp))
   ((if (minusp n)
      (not (member (substr str 1 1) pat))
      (member (substr str 1 1) pat)
    ) ;_ end of if
    (if (/= temp "")
      (cons temp (rec-pat "" str pat (- n)))
      (rec-pat "" str pat (- n))
    ) ;_ end of if
   )
   (t
    (rec-pat (strcat temp (substr str 1 1))
      (substr str 2)
      pat
      n
    ) ;_ end of trim_gap
   )
    ) ;_ end of cond
  ) ;_ end of defun
  (rec-pat ""
    str
    '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ".")
    1
  ) ;_ end of rec-pat
) ;_ end of defun
|;

(defun _dwgru-get-spds-text-and-range (/ selset lst)
                                      ;|
*    ?????????? ?????? ????? ?????????? ???????. ? ????? ???????? ??????? ???????,
* ??????????? ???????, ?????? ? ???????????.
*    ????????? ??????:
	???
*    ??????? ??????:
(_dwgru-get-spds-text)
	;
|;
  (if
    (and
      (= (type (setq selset (vl-catch-all-apply
                              (function (lambda () (ssget)))
                              ) ;_ end of vl-catch-all-apply
                     ) ;_ end of setq
               ) ;_ end of type
         'pickset
         ) ;_ end of =
      (setq selset
             (vl-remove-if-not
               (function
                 (lambda (x)
                   (member (cdr (assoc 0 x))
                           '("spdsNotePosition"
                             ;"spdsNoteKnot"
                             "spdsNoteComb"
                             "spdsNoteChain"
                             )
                           ) ;_ end of member
                   ) ;_ end of lambda
                 ) ;_ end of function
               (mapcar
                 (function (lambda (a)
                             (vl-remove-if-not
                               '(lambda (b) (member (car b) '(0 300 301 90)))
                               (entget a)
                               ) ;_ end of vl-remove-if-not
                             ) ;_ end of lambda
                           ) ;_ end of function
                 (_dwgru-conv-pickset-to-list selset)
                 ) ;_ end of mapcar
               ) ;_ end of vl-remove-if-not
            ) ;_ end of setq
      ) ;_ end of and
     (setq
       lst
        (mapcar
          (function
            (lambda (item)
              (cond
                ((= (cdr (assoc 0 item)) "spdsNoteKnot")
                 (append (mapcar
                           (function cdr)
                           (vl-remove-if-not
                             (function
                               (lambda (x)
                                 (= (car x) 300)
                                 ) ;_ end of lambda
                               ) ;_ end of function
                             (reverse
                               (member '(301 . "???????????? ??????")
                                       (reverse (member '(301 . "????? ????") item))
                                       ) ;_ end of member
                               ) ;_ end of reverse
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of mapcar
                         (list 1)
                         ) ;_ end of append
                 )
                ((= (cdr (assoc 0 item)) "spdsNotePosition")
                 (append (mapcar
                           (function cdr)
                           (vl-remove-if-not
                             (function
                               (lambda (x)
                                 (= (car x) 300)
                                 ) ;_ end of lambda
                               ) ;_ end of function
                             (member '(301 . "?????? ??????") item)
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of mapcar
                         (list 1)
                         ) ;_ end of append
                 )
                ((member (cdr (assoc 0 item))
                         '("spdsNoteComb" "spdsNoteChain")
                         ) ;_ end of member
                 (append
                   (mapcar
                     (function cdr)
                     (vl-remove-if-not
                       (function
                         (lambda (x)
                           (= (car x) 300)
                           ) ;_ end of lambda
                         ) ;_ end of function
                       (reverse
                         (member '(301 . "???????????? ??????")
                                 (reverse (member '(301 . "?????? ??????") item))
                                 ) ;_ end of member
                         ) ;_ end of reverse
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of mapcar
                   (list (cdr (assoc 90 (reverse item))))
                   ) ;_ end of cons
                 )
                ) ;_ end of cond
              ) ;_ end of lambda
            ) ;_ end of function
          selset
          ) ;_ end of mapcar
       ) ;_ end of setq
     ) ;_ end of if
  lst
  ) ;_ end of defun


(defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "??" (cadr x))
                  "????*,\\U+E72E*,?????*,??.*,????*,??????*,\\U+E720*,??????*,\\U+E725*,???????*,\\U+E729*,???????*,??????*,??.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*,\\U+0547\\U+0580\\U+057?\\U+0561\\U+0576*,\\U+053d\\U+0578\\U+0572*,\\U+0578\\U+057d\\U+057a\\U+0561\\U+0571\\U+0587*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun


(setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
 
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq

Дошел то этого места

5. Находим в ntt код Код: (setq lst (mapcar '(lambda (x) (list (vl-string-trim " " (car x)) (vl-string-trim " " (cadr x)) ) ;_ end of list ) ;_ end of lambda ;;; lst (_dwgru-get-spds-text-and-range) ; из #472 ) ;_ end of mapcar ) ;_ end of setq выполняем его так же, как и в п.2 и смотрим результат в VLIDE (указываем в чертеже только те объекты, которые нам нужны для проверки)

После этого в AutoCAD-е предлагается что-то выбрать. Что именно нужно выбрать. Я думал что выноску, но при выборе не только армянской но и русской выноски у меня возвращается такой ответ

; error: bad argument type: (or stringp symbolp): 1 _$

[CB]

>Red Nova

Я же тебе сказал ОТКРЫТЬ в VLIDE лисп, а не скопировать его из файла (посмотри что у тебя делается в лиспе - одни вопросы) , т.е. заходишь в VLIDE, нажимаешь кнопку Open file, находишь lsp-файл в котором у тебя находится функция _dwgru-get-spds-text-and-range, загружаем ее (см.п.2). Точно также открываем файл с функцией ntt.
Далее выполняешь п.5, выбираешь армянскую выноску и скриншот результата сюда - для того чтобы определиться с правильностью выбора шаблона для армянской выноски.

[Red Nova]

CB,
Вот что вернуло

Код:

[Выделить все]

(("5" "\U+0539\U+056B\U+0569\U+0565\U+0572 \U+0577\U+0565\U+0572\U+0561\U+0576\U+056F\U+0575\U+0578\U+0582\U+0576 -10x100x1000") ("4" "\U+0539\U+056B\U+0569\U+0565\U+0572 \U+0578\U+057D\U+057A\U+0561\U+0571\U+0587 -10x100x1000") ("3" "\U+053D\U+0578\U+0572\U+0578\U+057E\U+0561\U+056F \U+E71250x3") ("2" "\U+053D\U+0578\U+0572. \U+E71250x3") ("1" "\U+0547\U+0580\U+057B\U+0561\U+0576 \U+E712500x10"))

То есть употребляятся следуящие армянские слова

\U+0539\U+056B\U+0569\U+0565\U+0572*,\U+053D\U+0578\U+0572*,\U+0547\U+0580\U+057B\U+0561\U+0576*

Правлю код ntt

Код:

[Выделить все]

(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
                  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*,\U+0539\U+056B\U+0569\U+0565\U+0572*,\U+053D\U+0578\U+0572*,\U+0547\U+0580\U+057B\U+0561\U+0576*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun

  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
		    
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл" "\U+0547\U+0580\U+057B\U+0561\U+0576")
                   (list "Лист чечевица" "Лист ромб" "\U+0539\U+056B\U+0569\U+0565\U+0572 \U+0577\U+0565\U+0572\U+0561\U+0576\U+056F\U+0575\U+0578\U+0582\U+0576" "\U+0539\U+056B\U+0569\U+0565\U+0572 \U+0578\U+057D\U+057A\U+0561\U+0571\U+0587")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр" "\U+053D\U+0578\U+0572." "\U+053D\U+0578\U+0572\U+0578\U+057E\U+0561\U+056F")
		   (list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
                   (list "Болт")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
		   "СТО АСЧМ 20-93" 
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
                   "ГОСТ 7798-703"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
(princ)
) ;_ end of defun ntt

Пробую

Код:

[Выделить все]

Command: _ntt
Select objects: Specify opposite corner: 5 found

Select objects:

Выберите шаблон спецификации:
Select objects: Specify opposite corner: 20 found

Select objects:
; error: bad DXF group: (1)

Command:

[CB]

>Red Nova
Ты немного поспешил выполнять весь лисп...
Загрузить нужно не ntt, CB-filtr точно также как ты загружал до этого dwgru-get-spds-text-and-range (см.п.2).

Код:

[Выделить все]

(defun c:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
  (setq
    lst
.........

После загрузки выполни - (setq lst (CB-filtr lst)) (естественно это делаешь только после выполнения #145 , чтобы у нас была определена переменная lst). Если результат будет nil, то значит шаблон сделан не правильно и не прошел через фильтр. Сделай это обязательно.
Но я думаю, что в шаблоне просто нужно ставить двойной cлэш -

Код:

[Выделить все]

.....,##\\U+E712*,## \\U+E712*,\\U+0539\\U+056B\\U+0569\\U+0565\\U+0572*,\\U+053D\\U+0578\\U+0572*,\\U+0547\\U+0580\\U+057B\\U+0561\\U+0576*"

Только после того, как CB-filtr даст нужный результат делай изменения дальше - по п.8

[Red Nova]

После загрузки выполни - (setq lst (CB-filtr lst)) (естественно это делаешь только после выполнения #145 , чтобы у нас была определена переменная lst). Если результат будет nil, то значит шаблон сделан не правильно и не прошел через фильтр.

Выполняю, через фильтр проходит, но в окончательном коде не работает.

[CB]

Там где выделено красным добавь армянские символы, относящиеся к листу и фланцу...

Код:

[Выделить все]

(defun C:ntt (/ CB-filtr lst LST-AS)    ;note to text
  (defun CB-filtr (lst)
    (setq
      lst
       (vl-remove-if
         '(lambda (x)
            (or
              (not (equal (length x) 2))
              (member "" x)
              (not
                (wcmatch
                  (vl-string-translate "Tp" "Тр" (cadr x))
                  "Болт*,\\U+E72E*,Труба*,Тр.*,Лист*,Полоса*,\\U+E720*,Уголок*,\\U+E725*,Швеллер*,\\U+E729*,Двутавр*,Фланец*,Фл.*,-*,%%c*,\\U+E712*,#%%c*,# %%c*,##%%c*,## %%c*,#\\U+E712*,# \\U+E712*,##\\U+E712*,## \\U+E712*,\\U+0539\\U+056B\\U+0569\\U+0565\\U+0572*,\\U+053D\\U+0578\\U+0572*,\\U+0547\\U+0580\\U+057B\\U+0561\\U+0576*"
                ) ;_ end of wcmatch
              ) ;_ end of not
              (not
                (or
                  (and
                    (wcmatch (car x) "@*")
                    (wcmatch (vl-string-right-trim "1234567890'\"" (car x))
                             "@"
                    ) ;_ end of wcmatch
                  ) ;_ end of and
                  (and (wcmatch (car x) "#*")
                       (wcmatch (vl-string-left-trim "1234567890" (car x))
                                ",@,@',@\",',\""
                       ) ;_ end of wcmatch
                  ) ;_ end of and
                ) ;_ end of or
              ) ;_ end of not
            ) ;_ end of or
          ) ;_ end of lambda
         lst
       ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq lst
           ((lambda (lst / poz temp)
              (defun poz (str pat / p n)
                (while (setq n (vl-string-search pat str n))
                  (setq p (cons n p)
                        n (1+ n)
                  ) ;_ end of setq
                ) ;_ end of while
                p
              ) ;_ end of defun
              (while lst
                (setq
                  temp
                   (cons
                     ((lambda (lst-temp / n)
                        (list
                          (car lst-temp)
                          (vl-string-left-trim
                            "1234567890 "
                            (if (or
                                  (equal (length
                                           (setq n (poz (cadr lst-temp) ","))
                                         ) ;_ end of length
                                         2
                                  ) ;_ end of equal
                                  (not (wcmatch (cadr lst-temp) "*L=*"))
                                ) ;_ end of or
                              (substr (cadr lst-temp)
                                      1
                                      (if (wcmatch (cadr lst-temp) "*L=*")
                                        (car n)
                                        (car (reverse n))
                                      ) ;_ end of if
                              ) ;_ end of substr
                              (cadr lst-temp)
                            ) ;_ end of if
                          ) ;_ end of vl-string-left-trim
                        ) ;_ end of list
                      ) ;_ end of lambda
                       (car
                         (vl-sort
                           (vl-remove-if-not
                             '(lambda (x) (equal (caar lst) (car x)))
                             lst
                           ) ;_ end of vl-remove-if-not
                           '(lambda (str1 str2)
                              (>
                                (+ (length (poz (cadr str1) ","))
                                   (if (wcmatch (cadr str1) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                                (+ (length (poz (cadr str2) ","))
                                   (if (wcmatch (cadr str2) "*L=*")
                                     1
                                     0
                                   ) ;_ end of if
                                ) ;_ end of +
                              ) ;_ end of >
                            ) ;_ end of lambda
                         ) ;_ end of vl-sort
                       ) ;_ end of car
                     )
                     temp
                   ) ;_ end of cons
                ) ;_ end of setq
                (setq lst
                       (vl-remove-if '(lambda (x) (equal (caar lst) (car x))) lst)
                ) ;_ end of setq
                (reverse temp)
              ) ;_ end of while
            ) ;_ end of lambda
             lst
           )
    ) ;_ end of setq
  ) ;_ end of defun
  (setq lst (mapcar '(lambda (x)
                       (list (vl-string-trim " " (car x))
                             (vl-string-trim " " (cadr x))
                       ) ;_ end of list
                     ) ;_ end of lambda
;;;                    lst
                    (_dwgru-get-spds-text-and-range) ; из #472 
            ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst (CB-filtr lst))
  (setq lst
         (mapcar
           '(lambda (x / p)
              (if (setq p (vl-string-position (ascii ",") (cadr x)))
                (list
                  (car x)
                  (substr (cadr x) 1 p)
                  (vl-string-left-trim " " (substr (cadr x) (+ 2 p)))
                ) ;_ end of list
                (if (wcmatch (cadr x) "-*,Лист*,Фл*,")
                  (append x '("-"))
                  (append x '("L="))
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq lst
         (mapcar
           '(lambda (x) (nth x lst))
           (vl-sort-i
             ((lambda (lst)
                (mapcar
                  '(lambda (str1 str2)
                     (if (wcmatch str2 "@*")
                       (strcat (substr str2 1 1) str1 (substr str2 2))
                       (strcat str1 str2)
                     ) ;_ end of if
                   ) ;_ end of lambda
                  (mapcar
                    '(lambda (x / str)
                       (setq str "0")
                       (repeat x
                         (setq str (strcat str "0"))
                       ) ;_ end of repeat
                       str
                     ) ;_ end of lambda
                    ((lambda (a)
                       (mapcar '(lambda (x) (- (apply 'max a) x)) a)
                     ) ;_ end of lambda
                      (mapcar
                        '(lambda (str)
                           (length
                             (vl-remove-if-not
                               '(lambda (x)
                                  (wcmatch x "#")
                                ) ;_ end of lambda
                               (mapcar 'chr (vl-string->list str))
                             ) ;_ end of vl-remove-if-not
                           ) ;_ end of length
                         ) ;_ end of lambda
                        lst
                      ) ;_ end of mapcar
                    )
                  ) ;_ end of mapcar
                  lst
                ) ;_ end of mapcar
              ) ;_ end of lambda
               (mapcar 'strcase (mapcar 'car lst))
             )
             '<
           ) ;_ end of vl-sort-i
         ) ;_ end of mapcar
  ) ;_ end of setq
  (setq LST-AS
         (apply
           'append
           (mapcar
             '(lambda (X Y)
                (mapcar
                  '(lambda (Z)
                     (cons Z Y)
                   ) ;_ end of lambda
                  X
                ) ;_ end of mapcar
              ) ;_ end of lambda
             (list (list "Лист -" "Лист-" "Фл" "\\U+0547\\U+0580\\U+057B\\U+0561\\U+0576")
                   (list "Лист чечевица" "Лист ромб" "\\U+0539\\U+056B\\U+0569\\U+0565\\U+0572 \\U+0577\\U+0565\\U+0572\\U+0561\\U+0576\\U+056F\\U+0575\\U+0578\\U+0582\\U+0576" "\\U+0539\\U+056B\\U+0569\\U+0565\\U+0572 \\U+0578\\U+057D\\U+057A\\U+0561\\U+0571\\U+0587")
                   (list "-")
                   (list "Полоса")
                   (list "Уголок" "\\U+E720")
                   (list "\\U+E72E")
                   (list "Тр" "\\U+053D\\U+0578\\U+0572." "\\U+053D\\U+0578\\U+0572\\U+0578\\U+057E\\U+0561\\U+056F")
     (list "Двутавр*#*#[БКШ]" "\\U+E729*#*#[БКШ]")
                   (list "Двутавр" "\\U+E729")
                   (list "Швеллер" "\\U+E725")
                   (list "%%c" "\\U+E712")
                   (list "Болт")
             ) ;_ end of list
             (list "ГОСТ 19903-74"
                   "ГОСТ 8568-77"
                   (list "ГОСТ 19903-74" "ГОСТ 103-76")
                   "ГОСТ 103-76"
                   (list "ГОСТ 8509-93" "ГОСТ 8510-86")
                   "ГОСТ 30245-03"
                   "ГОСТ 10704-91"
     "СТО АСЧМ 20-93" 
                   "ГОСТ 8239-89"
                   "ГОСТ 8240-97"
                   "ГОСТ 5781-82"
                   "ГОСТ 7798-703"
             ) ;_ end of list
           ) ;_ end of mapcar
         ) ;_ end of apply
  ) ;_ end of setq LST-AS
  (setq lst
         (mapcar
           '(lambda (EL-LST / EL-AS)
              (setq EL-AS
                     (car
                       (vl-remove-if-not
                         '(lambda (STR)
                            (wcmatch (cadr EL-LST) (strcat (car STR) "*"))
                          ) ;_ end of lambda
                         LST-AS
                       ) ;_ end of vl-remove-if-not
                     ) ;_ end of car
              ) ;_ end of setq
              (cons
                (car EL-LST)
                (cons
                  (cond
                    ((equal (car EL-AS) "-")
                     (if (equal (caddr EL-LST) "-")
                       (cadr EL-AS)
                       (caddr EL-AS)
                     ) ;_ end of if
                    )
                    ((member (car EL-AS) '("Уголок" "\\U+E720"))
                     (if
                       ((lambda (STR)
                          (equal
                            (vl-string-position (ascii "x") STR)
                            (vl-string-position (ascii "x") STR nil t)
                          ) ;_ end of equal
                        ) ;_ end of lambda
                         (vl-string-translate "х" "x" (cadr EL-LST))
                       )
                        (cadr EL-AS)
                        (caddr EL-AS)
                     ) ;_ end of if
                    )
                    (t (cdr EL-AS))
                  ) ;_ end of cond
                  (cdr EL-LST)
                ) ;_ end of cons
              ) ;_ end of cons
            ) ;_ end of lambda
           lst
         ) ;_ end of mapcar
  ) ;_ end of setq
  ((lambda (/ b1 a1 a2 a3)
     (mapcar
       '(lambda (B A / b1 a1 a2 a3)
          ((lambda (dxf)
             (entmod
               (subst (cons 1 A)
                      (assoc 1 dxf)
                      dxf
               ) ;_ end of subst
             ) ;_ end of entmod
           ) ;_ end of lambda
            (entget B)
          )
        ) ;_ end of lambda
       (setq b1
              ((lambda (/ sset)
                 (princ "\nВыберите шаблон спецификации: ")
                 (if (setq sset (ssget '((0 . "*TEXT"))))
                   (vl-sort
                     (vl-sort
                       (vl-remove-if
                         (function listp)
                         (mapcar (function cadr)
                                 (ssnamex sset)
                         ) ;_ end of mapcar
                       ) ;_ end of vl-remove-if
                       '(lambda (a b)
                          (> (caddr (assoc '10 (entget a)))
                             (caddr (assoc '10 (entget b)))
                          ) ;_ on Y
                        ) ;_ end of lambda
                     ) ;_ end of vl-sort
                     '(lambda (a b)
                        (and
                          (equal (caddr (assoc '10 (entget a)))
                                 (caddr (assoc '10 (entget b)))
                                 1.
                          ) ;_ end of equal
                          (< (cadr (assoc '10 (entget a)))
                             (cadr (assoc '10 (entget b)))
                          ) ;_ end of <
                        ) ;_ end of and
                      ) ;_ end of lambda
                   ) ;_ end of vl-sort
                 ) ;_ end of if
               ) ;_ end of lambda
              )
       ) ;_ end of setq
       (progn
         (setq a1 (apply 'append lst)
               a1
                  (append
                    a1
                    (if (not (minusp (setq a2 (- (length b1) (length a1)))))
                      (append (repeat a2 (setq a3 (cons "XX" a3))))
                    ) ;_ end of if
                  ) ;_ end of append
         ) ;_ end of setq
       ) ;_ end of progn
     ) ;_ end of mapcar
   ) ;_ end of lambda
  )
(princ)
) ;_ end of defun ntt

[ShaggyDoc]

А не смущает, что условия поиска чрезвычайно ненадежны в принципе?

Символы шрифта с кодами E720, E725 и т.п. обозначающие "уголок", "швеллер" и т.д. привязаны к частному шрифту. Видимо, CS_GOST или его собратьям.
В этих шрифтах на такие позиции нарисовали уголки и прочий прокат. Но это же совсем не соответствует стандартам Unicode.

Там для каждых групп символов (английский, армянский, кириллица, математика, пунктуация и т.п.) отводятся определенные диапазоны адресов. 0E00—0E7F относятся к "тайскому письму". Обидятся тайцы-то.

Возьмут, и в армянский диапазон какие-нибудь свои "бамбуки" воткнут. Ладно, их обиду переживем. Но ведь в любом другом шрифте "уголки" и "швеллера" могут оказаться на другом месте. И код уголка может оказаться, например, где-нибудь в диапазоне 2300—23FF, там где и должны находиться "разнообразные технические символы".

Вечно будете программу переделывать. А можно сразу правильно.

[CB]

А как правильно?

[Red Nova]

CB, Заработало. Спасибо.

ShaggyDoc,
Для тех кто пользуется обычными шрифтами в лиспе есть возможность записи профилей по имени, например "Уголок 75x5"

[ShaggyDoc]

В ТЗ верху страницы было множество "должны". Потом, по ходу разборок, появилось множество уточнений. И это всего лишь по поводу таких простейших описаний, как прокат. Типа Уголок 75х5. Теперь уже "есть возможность" появляется.

Но, даже здесь могут быть варианты. Кто-то сделает опечатку, кто-то напишет "х" русским символом, кто-то английским. Кто-то сделает несколько выносок, указывающих на одну и ту же конструкцию, а кто-то ни одной. Простейшее действие обрастает таким множеством формльных требований, что гораздо проще и надежнее будет выполнить спецификацию вручную.

А если вообще надо только позиции указывать? А если надписи будут в иных случаях, более длинные, с еще большим количеством вариантов для ошибок?

А как правильно? Да в разных вариантах, но не так. Я уже писал в #128.

Здесь надо разделить хранение данных, маркировку, подсчет количеств и оформление.

Данные надо хранить в базе данных. Она может быть и "настоящей", а может быть и простой. Даже такой - в виде файлов в подкаталогах. Каждый файлик - описание изделия, в простейшем виде строка. Но ведь для спецификаций нужно, как минимум, несколько параметров - наименование, обозначение (ГОСТ, ТУ), масса и т.п. А может быть и клиент-серверная.

При маркировке производится визуальный выбор из БД. Чего угодно. Сама маркировка может и выноской делаться. Здесь можно и наименование из БД взять (уже автоматически), а можно и позицию номером поставить. А можно и просто на изображение изделия ткнуть.

Секрет в том, что к этой видимой марке надо привязать невидимые для пользователя данные. В виде xdata, например. Но там всего лишь ссылка на базу данных (запись), а не сами данные.

В момент подсчета количеств анализируются не тексты надписей, а ссылки на БД. Там-то уже ошибок нет. А в момент оформления нужные надписи извлекаются из БД и вписываются в любое место в любой необходимой форме. На любом языке.

Вот такая программа становится пригодна для специфицирования чего угодно.

[Кулик Алексей aka kpblc]

Все, что говорит ShaggyDoc, верно. Одно "но": объекты СПДС такому "насилию" вряд ли поддадутся. Лично мне, например, не удалось программно создать объекты выноски, модифицировать его, да еще и "погасить"* или заранее вбить в выноску нужные данные. Ведь заранее неизвестны ни точка вставки, ни радиус (а то и форма) "оконечника" стрелки, ни точка перегиба.
---
Добавлено: иногда лучше пользоваться старыми и глючными LEADER'ами и писать лишние командные реакторы. И огрести по полной
---
Добавлено 2:
* Имеется в виду "погасить диалог"

[Red Nova]

ShaggyDoc,
Ничего не имею против такой версии, но на мой взгляд поим алгоритмом и алгоритмом описанным в #153 преследуются разные цели.
Я главной целью ставил то, чтобы не делать одну и ту же работу дважды, то есть имея выноску с заполненными данными о профиле хочется быстро скопировать ее содержание в спецификацию.
-У меня нет цели абсолютно всю спеку собрать автоматически.
-Графа количество записывается отдельно, ручками.
-Собирает спеку один лисп, рассчитывает другой, про это есть отдельная тема.
Теперь отвечу на замечания.

В ТЗ верху страницы было множество "должны". Потом, по ходу разборок, появилось множество уточнений. И это всего лишь по поводу таких простейших описаний, как прокат. Типа Уголок 75х5. Теперь уже "есть возможность" появляется.

В шапке я изложил основные принципы которые задумал в самом начале. По ходу дела многое усовершенствовалось.

Кто-то сделает опечатку, кто-то напишет "х" русским символом, кто-то английским.

Учтено

Кто-то сделает несколько выносок, указывающих на одну и ту же конструкцию, а кто-то ни одной.

Дублирование учтено, а если такой позиции нет, то как говорится "на нет и суда нет", позицию пропускаем.

Простейшее действие обрастает таким множеством формльных требований, что гораздо проще и надежнее будет выполнить спецификацию вручную.

Не согласен

А если вообще надо только позиции указывать?

Ради бога, тогда делаем спеку ручками, ведь смысл лиспа в том чтобы одну и ту же работу дважды не делать, если на чертеже дал только номера позиций, то и в спеке не жалко ручками пописать.

А если надписи будут в иных случаях, более длинные, с еще большим количеством вариантов для ошибок?

Старались по максимуму учесть.
В общем то на данный момент разработан довольно не плохой многоуровневый фильтр выносок. тут аш на восьми листах шла разработка этого самого фильтра. Многое учтено. Конечно же это не идеальный вариант, но такой цели и не ставилось.

P.S. Ради наглядности открыл один старый проект, который я сделал еще до того как лисп был создан, и сделал ролик работы лиспа на нем. Даю слово что открыл проект на угад и не делал в нем никаких корректировок чтобы лисп работал более гладко. Как видно в файле куча выносок с самым различным содержанием. Отметил все объекты файла, в результате сбора спецификации все позиции собрались нормально. Отсутствуют только позиции 3, 4 и 9, и то потому что я их не описывал на чертеже, а в выноске только дал номер позиции. Принимаю что у другого товарища в файле может творится совсем другое, но все же, по моему эффектно…

[DEM]

Red Nova
Просто не вижу смысла в описании параметров объекта(чертежа) выносками да еще в них столько информации запихивать, количество объектов поменял и опять меняй выноску. Я вот сейчас хочу попробовать сделать не сколько десятков объектов СПДС для армирования, и попробовать армировать ими с автоматическим созданием спецификации, причем эта спецификация будет интерактивна поменял что то на чертеже и соответственно поменялось в спецификации.
А у вас получатся надо выполнять в 2 захода тоже самое, причем еще с доработкой руками.

PS. КрЫС а попробуй использовать маркер а не выноску, там точка втставки есть и её можно изменять, вставку можно производить через инсерт с указанныой точкой(конец выносной линии), тем самым ты будешь контролировать местоположение маркера, ну а текст там подправить легко.
А по хорошему мог бы и Якова по теребить, может он помог бы.

[dextron3]

DEM, дело говоришь, а можно ли когда зоздал спецификацию из спдсных выносок, в спецификации делать уже ассоциативные тексты с спднсыми выносками, тоесть выносками управлять с помощью спецификации, или наобород?

ну я не не знаяю как это конкретно выглядеть и с помощью каких команд конечно решаться будет, может ссылки или фиелдами, но как говориться при исправлениях работу бы сократило вдвое, хотя и так работы вдвое меньше стало в связи с кризисом и люди меньше фотографироваться стали почему то..

[DEM]

dextron3
Можно причем если использовать маркеры то работать можно уже и без всяких ЛИСПов, причем обозначения уже не надо будет выводить на экран, то есть грубо говоря, маркер внутри будет уже содержать информацию о объекте, а снаружи просто поз. цифрой обозначаешь и все.

[DEM]

В общем вот что за 5 мин состряпал
Надо конечно 2-3 дня по сидеть и сделать по нормальному
PS. SPDS 5

[Red Nova]

DEM,
И далась тебе эта 5-я версия. В ней было столько глюков что я ее убрал куда по дальше.