При выводе результата число округляется в соответствии
с текущими установками переменной LUPREC. Команда _UNITS
|;
(defun c:sumT ( / res selset ins_pt txt_height blk obj ed *error*)
(defun *error* (msg)
(setvar "NOMUTT" 0) ;_ Восстанавливаем NOMUTT
(princ msg)
)
(vl-load-com)(setq res 0.)
(princ "\nВыберите тексты или размеры: ")
(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 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 (+ res (apply '+ (mapcar 'atof str))))
)
)
) ;_ end of foreach
) ;_ end of if
(princ "\nРезультат=")(princ (rtos res 2))
(if (not (equal res 0. 1e-3))
(progn
(if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0) ;_ end of =
(progn ;; нулевая высота текста
(if (not (setq txt_height (getreal "\nВведите высоту текста : ")))(setq txt_height 250))
(vl-cmdf "_.TEXT" "0,0" txt_height 0 (rtos res 2))) ;_ end of progn
(progn ;; фиксированнная высота
(vl-cmdf "_.TEXT" "0,0" 0 txt (rtos res 2))) ;_ end of progn
)
(command "_.copybase" "0,0" (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)
) ;_ end of progn
) ;_ end of if
(princ)
)
(princ "\nНаберите в командной строке SumT")
(defun mip_MTEXT_Unformat ( Mtext / text Str )
(setq Text "")
(while (/= Mtext "")
(cond
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
(setq Mtext (substr Mtext 3) Text (strcat Text Str)))
((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
(setq Mtext (substr Mtext 3)))
((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
(setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
((wcmatch (strcase (substr Mtext 1 2)) "\\P")
(if (or(= " " (substr Text (strlen Text)))
(= " " (substr Mtext 3 1)))
(setq Mtext (substr Mtext 3))
(setq Mtext (substr Mtext 3) Text (strcat Text " "))))
((wcmatch (strcase (substr Mtext 1 2)) "\\S")
(setq Str (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
Mtext (substr Mtext (+ 4 (strlen Str)))))
(t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))
))
Text
)
;|
* Ф-ция 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