[Profan]

Оригинал темы находился на форуме autocad.ru. Теперь caduser.ru

Александр Ривилис (2006-02-27 14:12:02)

Код:

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

 
;------------------------------------------------
; Команда: AREATLB
; Эта команда позволяет вставить в заданную
; ячейку таблицы поле (FIELD), соответствуещее
; площади выбранного примитива. Так как это поле
; связано с конкретным примитивом, то при изменении
; примитива поле пересчитывается (необходима
; регенерация)
;------------------------------------------------
(defun C:AREATLB ( / en obj s row col)
(vl-load-com)
(cond
((and (setq en (car (entsel "\nВыберите таблицу: ")))
(= (cdr (assoc 0 (entget en))) "ACAD_TABLE"))
(setq obj (vlax-ename->vla-object en))
(while (setq en (car (entsel "\nВыберите примитив для вставки его площади в таблицу (ENTER — завершение): " )))
(cond
((vlax-property-available-p (vlax-ename->vla-object en) 'Area)
(setq s (strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string (vla-get-objectid (vlax-ename->vla-object en)))
">%).Area>%"
))
(if (setq p (getpoint "\nУкажите ячейку таблицы: " ))(progn
(if (= :vlax-true (vla-HitTest obj
(vlax-3d-point (trans p 1 0)) (vlax-3d-point (trans (getvar "VIEWDIR") 1 0)) 'row 'col))
(vla-SetText obj row col s)
)
)) ;_endof if progn
)
(t
(princ "\nДля этого примитива невозможно получить свойство Area!")
)
)
)
)
(t
(princ "\nЭто не таблица!")
)
)
(princ)
)

Александр Ривилис (2006-02-27 14:56:06)

P.S.:
1) Если необходимо, чтобы площадь вычислялась с заданными установками UNITS необходимо:
строку ">%).Area>%" заменить на строку ">%).Area \\f \"%lu6%qf1\">%"
2) Если площадь вычисляется в мм^2, а нужно в м^2, то эта строка соответственно заменяется на ">%).Area \\f \"%lu6%qf1%ct8[1e-006]\">%"
3) И т.д.

Владимир Громов (2006-03-25 21:53:47)

Программа хорошо работает. Но мне пришла в голову мысль объединить операции отрисовки контура и вставки значения площади в таблицу. На основе кода Александра Ривилиса получилась такая программа:

Код:

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

 
;------------------------------------------------------------
; Команда: PLAREATAB
; Эта команда позволяет вставить в заданную
; ячейку таблицы поле (FIELD), содержащее значение
; площади построенного контура. Так как это поле
; связано с конкретным объектом, то при изменении
; объекта поле пересчитывается (необходимо обновление
; поля)
; Код можно сохранить в файле plareatab.lsp
; Возможный макрос для кнопки или пункта меню:
; ^C^C(if (not C:PLAREATAB) (load "plareatab")) PLAREATAB
;------------------------------------------------------------
(defun C:PLAREATAB ( / echo en obj s row col)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(vl-load-com)
(vl-cmdf "_.UNDO" "_be")
(cond
((and (setq en (car (entsel "\n Выберите таблицу: ")))
(= (cdr (assoc 0 (entget en))) "ACAD_TABLE"))
(setq obj (vlax-ename->vla-object en))
(setvar "CMDECHO" 1)
(princ "\n Нарисуем контур: ")
(command "_PLINE")
(while (/= (logand (getvar "cmdactive") 31) 0)
(command pause)
)
(setvar "CMDECHO" 0)
(setq en (entlast))
(cond
((vlax-property-available-p (vlax-ename->vla-object en) 'Area)
(setq s (strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string (vla-get-objectid (vlax-ename->vla-object en)))
">%).Area \\f \"%lu6%qf1%ct8[1e-006]\">%"
))
(if (setq p (getpoint "\n Укажите ячейку таблицы: " ))(progn
(if (= :vlax-true (vla-HitTest obj
(vlax-3d-point (trans p 1 0)) (vlax-3d-point (trans (getvar "VIEWDIR") 1 0)) 'row 'col))
(vla-SetText obj row col s)
)
)) ;_endof if progn
)
) ;cond
)
(t
(princ "\n Это не таблица!")
)
) ;cond
(vl-cmdf "_.UNDO" "_e")
(setvar "CMDECHO" echo)
(princ)
)

Здесь площадь из квадратных миллиметров преобразуется в квадратные метры. Точность вычисления площади определяется заданием количества знаков после точки в диалоговом окне "Единицы" ("Units").
А дальше можно для ячейки последней строки таблицы задать формулу "Сумма" и связать это поле с ячейками, в которые будет вставляться площадь. В результате в этой ячейке будет автоматически подсчитываться сумма площадей контуров. Только в формулу надо будет добавить множитель *0.000001 (для квадратных метров).
Ясно, что все это будет работать только в AutoCAD 2006 и в последующих версиях.

VVA (2007-09-20 16:36:57)
По просьбе отсюда.
http://www.autocad.ru/cgi-bin/f1/boa...38227Nu&page=3
Скрещенные команды Владимира Громова и Александра Ривилиса + если указали ячейку таблицы, то поле с площадью вставится в ячейку, иначе в это место вставится текст в полем. Точность округления и масштабный коэффициент настраиваются через опцию Установки

Код:

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

 
; Команда: PAREATAB
; Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы
; текст с полем (FIELD), содержащее значение площади построенного или выбранного контура.
; Точность округления и масштабный коэффициент настраиваются через опцию Установки
; Так как это поле связано с конкретным объектом, то при изменении
; объекта поле пересчитывается (необходимо обновление поля)
; Код можно сохранить в файле pareatab.lsp
; Возможный макрос для кнопки или пункта меню:
; ^C^C(if (not C:PAREATAB) (load "pareatab"));PLAREATAB;
(defun C:PAREATLB ( / en cmdname fld txt fc tblset tblobj row col pt
whatAcadVer)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008
(defun whatAcadVer ( / Aver)
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond ((= Aver 17.1) 2008)((= Aver 17.0) 2007)((= Aver 16.2) 2006)
((= Aver 16.1) 2005)((= Aver 16.0) 2004)((= Aver 15.06) 2002)
(t 0)))
(vl-load-com)
(or *SCALE* (setq *SCALE* 1))
(or *PREC* (setq *PREC* 2))
(or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
(princ "\nТекущий масштаб = ")(princ *SCALE*)
(princ " Текущая точность округления = ")(princ *PREC*)
(princ " Высота текста = ")(princ *TEXTSIZE*)
(initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
(and
(or ;_ > Проверяем версию
(> (whatAcadVer) 2005)
(alert "\nНужен Автокад версии 2006 и выше")
) ;_ < Проверяем версию
(or ;_ > Запрашиваем что рисовать + опции
(while (= (setq cmdname (getkword "\nВыберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: "))
"Setting")
(princ "\nНовый масштабный коэффициент <")(princ *SCALE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *SCALE* en))
(princ "\nТочность округления <")(princ *PREC*)(princ "> : ")
(initget 4)
(if (setq en (getint))(setq *PREC* en))
(princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *TEXTSIZE* en))
(initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
)
t
) ;_ < Запрашиваем что рисовать + опции
(cond
((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
(while (> (getvar "CMDACTIVE") 0)(command pause))
(setq en (entlast))
)
((or (null cmdname)(= cmdname "sElect"))
(princ "\nВыберите полилинию, круг, сплайн, эллипс или дугу")
(and
(setq tblset (ssget "_:S:E" '((0 . "LINE,*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))))
(setq en (ssname tblset 0))
)
)
(t nil)
)
;_ Формируем поле
(setq fld (strcat
"%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string
(vla-get-objectid (vlax-ename->vla-object en))
) ;_ vl-princ-to-string
">%).Area \\f \"%lu2%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
) ;_ strcat
) ;_ setq
;_ Создаем текст
(setq txt (entmakex
(list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 72 0) ;_ выравнивание влево
(cons 1 fld)
;(cons 7 style) ;_Текущий стиль
;(cons 8 layer) ;_Текущий слой
(cons 10 '(0 0 0))
(cons 11 '(0 0 0))
(cons 40 *TEXTSIZE*) ;_Высота текста
) ;_ list
) ;_ entmakex
)
;_ Копируем в буфер и обратно
(setvar "cmdecho" 0)
(vl-cmdf "_updatefield" txt "")
(princ "\n Укажите точку вставки текста или ячейку таблицы:")
(vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
;_ В txt примитив текста в pt точка вставки
(setq txt (entlast) pt (getvar "LASTPOINT"))
(or
(and ;_Проверяем, попала ли точка в ячейку таблицы
(setq tblobj nil tblset (ssget "_X" '((0 . "ACAD_TABLE"))))
(setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
(mapcar '(lambda (x)
(or tblobj
(and
(= :vlax-true (vla-HitTest x
(vlax-3d-point (trans pt 1 0))
(vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
'row 'col))
(setq tblobj x)
)
)
)
lst)
tblobj row col
(or (vla-SetText tblobj row col fld) t)
(entdel txt)
)
(and ;_Не попала, рисуем текст с полем
(setq txt (vlax-ename->vla-object txt))
(vlax-write-enabled-p txt)
(vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
(vlax-property-available-p txt 'TextString)
(vlax-put txt 'TextString fld)
)
)
)
(princ)
)

alex (2007-10-01 18:40:41)

Все отлично, однако можно ли добавить следующее:
1. иногда мне надо мм2, а иногда м2, где и как это регулировать?
2. мне бы хотелось высоту буквы по текущему стилю.
3. фон, в который залито число, мне лично мешает
Заранее благодарен, идея отличная!

alex (2007-10-01 19:16:16)

С высотой текста разобрался, а вот:
1. иногда мне надо мм2, а иногда м2, где и как это регулировать?
3. фон, в который залито число, мне лично мешает
Заранее благодарен!

Владимир Громов (2007-10-01 19:21:45)

Хочу отметить одну особенность. Для одного объекта можно вставить несколько полей. Применительно к последней программе это означает, что одно поле может быть вставлено в пределах конкретного помещения, а другое поле — в ячейку таблицы (в экспликацию). При корректировке контура обновление полей синхронно изменяет значение площади в полях.

VVA (2007-10-02 09:51:23)

>alex (2007-10-01 19:16:16)
По п.3 команда _options
http://keep4u.ru/imgs/s/071002/c91e527a481b16b59f.jpg' />

по п.1 тебе нужен суффиск м2 и мм2 или преобразовывать число в м2 мм2

wo! (2007-10-02 11:19:23)

Что то у меня никак не получается, в чем дело?
Пишет
Команда: _appload pareatab.lsp успешно загружено.
Команда:
Команда: (if (not C:PAREATAB) (load "pareatab"))
Error:сбой при выполнении LOAD: "pareatab"; ошибка: В функции *error* возникла
ошибка:Настройка переменной AutoCAD отвергнута: "CMDECHO" nil
Команда: PLAREATAB
Неизвестная команда "PLAREATAB". Для вызова справки нажмите F1.
ACAD2006
C уважением, wo!

Незнайка (2007-10-02 18:38:13)

>VVA (2007-09-20 16:36:57)
типа претензии
1. почему по пробелу не повторить
2. можно ли сделать это для протяженности
3. можно ли сделать, чтоб не было необходимости выбирать ячейку, а данные сами подали в таблицу по заранее договоренному условию , т.е сиди и отщелкивай объекты

alex (2007-10-02 22:52:59)

Уважаемый VVA!
"по п.1 тебе нужен суффиск м2 и мм2 или преобразовывать число в м2 мм2"
желательно и то, и другое.
Я понимаю, что для простоты я сделаю два разных лиспа и отдельные кнопки, но где в лиспе добавить м2 или мм2 и где изменить множитель?
Кстати,VVA!Вы мне уже не первый раз помогаете!
Благодарен!

VVA (2007-10-03 10:19:16)

По порядку
>wo! (2007-10-02 11:19:23) и остальные
Я там в примечаниях допустил описку. Нужно читать так !!!

Код:

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

 
; Код можно сохранить в файле pareatlb.lsp
; Возможный макрос для кнопки или пункта меню:
; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;

Это по поводу неизвестная команда PLAREATAB
По поводу
« Error:сбой при выполнении LOAD »

Проверь скобки, особенно в начале и конце. Вожможно не все скопировал.
>Незнайка (2007-10-02 18:38:13)
1. Команда повторяется по пробелу. Или ты имеешь ввиду что-то другое?
2. Поясни, не понял про протяженность?
3. Это как говорится уже другая песТня. Освобожусь, м.б. попробую сделать. Кто и как оговаривает заранее условия?
>alex (2007-10-02 22:52:59)
Про суффиксы и перфиксы: добавлю
Про преюбразование: в команде есть опция "Установки". В ней меняй масштабный коэффициент для мм2 и м2. Можно и в редакторе поля отредактировать масштабный коэффициент.
Для разных масштабов кнопки могут быть такие:
^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;
Где
0.001 — масштабный коэффициент
2 — точность округления
5 — высота текста
Меняй числа не нужные тебе и клепай кнопки

Незнайка (2007-10-03 13:48:02)

>VVA (2007-10-03 10:19:16)
3. программа запрашивает условия. на что я отвечаю F1 F2. Программа отвечает, что поняла, и пошла мне клепать поля в ячейки F1,F2,F3,F4 , ну и пусть по горизонтали работает. Если я например, дурак и дал ей таблицу на мало строк, то пусть она на законных основаниях вываливается с ошибкой, а еще лучше, чтоб сама ячеек добавила.
2. у полилинии ( разомкнутой) еще есть помимо площади есть параметр протяженность(длина).
1. значит у меня галлюцинации
этот форум стёр мое четвертое предложение:
4.было бы не плохо добавить такую опцию, как простановка в соседней ячейки (E1,E2...)порядкового номера и назначение этого же номера гиперссылкой обработанному примитиву. т.е подвел курсор к примитиву. он посредством гиперссылки говорит что он 66 и смело могу найти его параметры в ячейке F66

VVA (2007-10-03 15:20:31)

>Незнайка (2007-10-03 13:48:02)
1. проехали
2. http://www.autocad.ru/cgi-bin/f1/board.cgi?t=38388nX
3. буду думать
4. попробуй FLDVIZ отсюда http://www.autocad.ru/cgi-bin/f1/boa...38227Nu&page=4. Там правда наоборот. Указыаешь поле (текст, атрибут, ячейку таблицы) и она посвечивает учавствующие примитивы

VVA (2007-10-03 17:18:04)

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

Код:

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

 
; Команда: PAREATLB
; Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы
; текст с полем (FIELD), содержащее значение площади построенного или выбранного контура.
; Точность округления и масштабный коэффициент настраиваются через опцию Установки
; Так как это поле связано с конкретным объектом, то при изменении
; объекта поле пересчитывается (необходимо обновление поля)
; Код можно сохранить в файле pareatlb.lsp
; Возможный макрос для кнопки или пункта меню:
; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;
;; Вариант макроса для задания м2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;м2;
;;Где
;; 0.001 — масштабный коэффициент
;; 2 — точность округления
;; 5 — высота текста
;; префикса нет
;; м2 — суффикс
;; Вариант макроса с использованием этого шрифта http://dwg.ru/dnl/147
;; Для м2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;/U+E738;
;; Для мм2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;м/U+E738;
(defun C:PAREATLB ( / en cmdname fld txt fc tblset tblobj row col pt
whatAcadVer)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008
(defun whatAcadVer ( / Aver)
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond ((= Aver 17.1) 2008)((= Aver 17.0) 2007)((= Aver 16.2) 2006)
((= Aver 16.1) 2005)((= Aver 16.0) 2004)((= Aver 15.06) 2002)
(t 0)))
(vl-load-com)
(or *SCALE* (setq *SCALE* 1))
(or *PREC* (setq *PREC* 2))
(or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
(or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
(setq *SUFF* (vl-princ-to-string *SUFF*))
(setq *PREF* (vl-princ-to-string *PREF*))
(princ "\nТекущий масштаб = ")(princ *SCALE*)
(princ " Текущая точность округления = ")(princ *PREC*)
(princ " Высота текста = ")(princ *TEXTSIZE*)
(princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
(initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
(and
(or ;_ > Проверяем версию
(> (whatAcadVer) 2005)
(alert "\nНужен Автокад версии 2006 и выше")
) ;_ < Проверяем версию
(or ;_ > Запрашиваем что рисовать + опции
(while (= (setq cmdname (getkword "\nВыберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: "))
"Setting")
(princ "\nНовый масштабный коэффициент <")(princ *SCALE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *SCALE* en))
(princ "\nТочность округления <")(princ *PREC*)(princ "> : ")
(initget 4)
(if (setq en (getint))(setq *PREC* en))
(princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *TEXTSIZE* en))
(princ "\nПрефикс (пробел — очистить) <")(princ *PREF*)(princ "> : ")
(if (= (setq en (getstring t)) " ")(setq en ""))
(if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
(setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
(princ "\nСуффикс (пробел — очистить) <")(princ *SUFF*)(princ "> : ")
(if (= (setq en (getstring t)) " ")(setq en ""))
(if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
(setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
(initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
)
t
) ;_ < Запрашиваем что рисовать + опции
(cond
((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
(while (> (getvar "CMDACTIVE") 0)(command pause))
(setq en (entlast))
)
((or (null cmdname)(= cmdname "sElect"))
(princ "\nВыберите полилинию, круг, сплайн, эллипс или дугу")
(and
(setq tblset (ssget "_:S:E" '((0 . "LINE,*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))))
(setq en (ssname tblset 0))
)
)
(t nil)
)
;_ Формируем поле
(setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string(vla-get-objectid (vlax-ename->vla-object en)))
">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
"]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
) ;_ strcat
) ;_ setq
;_ Создаем текст
(setq txt (entmakex
(list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 72 0) ;_ выравнивание влево
(cons 1 fld)
;(cons 7 style) ;_Текущий стиль
;(cons 8 layer) ;_Текущий слой
(cons 10 '(0 0 0))
(cons 11 '(0 0 0))
(cons 40 *TEXTSIZE*) ;_Высота текста
) ;_ list
) ;_ entmakex
)
;_ Копируем в буфер и обратно
(setvar "cmdecho" 0)
(vl-cmdf "_updatefield" txt "")
(princ "\n Укажите точку вставки текста или ячейку таблицы:")
(vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
;_ В txt примитив текста в pt точка вставки
(setq txt (entlast) pt (getvar "LASTPOINT"))
(or
(and ;_Проверяем, попала ли точка в ячейку таблицы
(setq tblobj nil tblset (ssget "_X" '((0 . "ACAD_TABLE"))))
(setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
(mapcar '(lambda (x)
(or tblobj
(and
(= :vlax-true (vla-HitTest x
(vlax-3d-point (trans pt 1 0))
(vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
'row 'col))
(setq tblobj x)
)
)
)
lst)
tblobj row col
(or (vla-SetText tblobj row col fld) t)
(entdel txt)
)
(and ;_Не попала, рисуем текст с полем
(setq txt (vlax-ename->vla-object txt))
(vlax-write-enabled-p txt)
(vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
(vlax-property-available-p txt 'TextString)
(vlax-put txt 'TextString fld)
)
)
)
(princ)
)

alex (2007-10-03 21:09:39)

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

alex (2007-10-03 21:20:04)

К предыдущему письму:
имеется ввиду если во второй раз заказать "установки" и по умолчанию со всем согласиться.

VVA (2007-10-04 10:26:53)

>alex (2007-10-03 21:20:04)
Исправил

Код:

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

 
; Команда: PAREATLB
; Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы
; текст с полем (FIELD), содержащее значение площади построенного или выбранного контура.
; Точность округления и масштабный коэффициент настраиваются через опцию Установки
; Так как это поле связано с конкретным объектом, то при изменении
; объекта поле пересчитывается (необходимо обновление поля)
; Код можно сохранить в файле pareatlb.lsp
; Возможный макрос для кнопки или пункта меню:
; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;
;; Вариант макроса для задания м2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;м2;
;;Где
;; 0.001 — масштабный коэффициент
;; 2 — точность округления
;; 5 — высота текста
;; префикса нет
;; м2 — суффикс
;; Вариант макроса с использованием этого шрифта http://dwg.ru/dnl/147
;; Для м2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;/U+E738;
;; Для мм2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;м/U+E738;
(defun C:PAREATLB ( / en cmdname fld txt fc tblset tblobj row col pt
whatAcadVer)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008
(defun whatAcadVer ( / Aver)
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond ((= Aver 17.1) 2008)((= Aver 17.0) 2007)((= Aver 16.2) 2006)
((= Aver 16.1) 2005)((= Aver 16.0) 2004)((= Aver 15.06) 2002)
(t 0)))
(vl-load-com)
(or *SCALE* (setq *SCALE* 1))
(or *PREC* (setq *PREC* 2))
(or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
(or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
(setq *SUFF* (vl-princ-to-string *SUFF*))
(setq *PREF* (vl-princ-to-string *PREF*))
(princ "\nТекущий масштаб = ")(princ *SCALE*)
(princ " Текущая точность округления = ")(princ *PREC*)
(princ " Высота текста = ")(princ *TEXTSIZE*)
(princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
(initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
(and
(or ;_ > Проверяем версию
(> (whatAcadVer) 2005)
(alert "\nНужен Автокад версии 2006 и выше")
) ;_ < Проверяем версию
(or ;_ > Запрашиваем что рисовать + опции
(while (= (setq cmdname (getkword "\nВыберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: "))
"Setting")
(princ "\nНовый масштабный коэффициент <")(princ *SCALE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *SCALE* en))
(princ "\nТочность округления <")(princ *PREC*)(princ "> : ")
(initget 4)
(if (setq en (getint))(setq *PREC* en))
(princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *TEXTSIZE* en))
(princ "\nПрефикс (пробел — очистить) <")(princ *PREF*)(princ "> : ")
(setq en (getstring t))(if (= en "")(setq en *PREF*))
(if (= en " ")(setq en ""))
(if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
(setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
(princ "\nСуффикс (пробел — очистить) <")(princ *SUFF*)(princ "> : ")
(setq en (getstring t))(if (= en "")(setq en *SUFF*))
(if (= en " ")(setq en ""))
(if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
(setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
(initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
)
t
) ;_ < Запрашиваем что рисовать + опции
(cond
((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
(while (> (getvar "CMDACTIVE") 0)(command pause))
(setq en (entlast))
)
((or (null cmdname)(= cmdname "sElect"))
(princ "\nВыберите полилинию, круг, сплайн, эллипс или дугу")
(and
(setq tblset (ssget "_:S:E" '((0 . "LINE,*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))))
(setq en (ssname tblset 0))
)
)
(t nil)
)
;_ Формируем поле
(setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string(vla-get-objectid (vlax-ename->vla-object en)))
">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
"]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
) ;_ strcat
) ;_ setq
;_ Создаем текст
(setq txt (entmakex
(list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 72 0) ;_ выравнивание влево
(cons 1 fld)
;(cons 7 style) ;_Текущий стиль
;(cons 8 layer) ;_Текущий слой
(cons 10 '(0 0 0))
(cons 11 '(0 0 0))
(cons 40 *TEXTSIZE*) ;_Высота текста
) ;_ list
) ;_ entmakex
)
;_ Копируем в буфер и обратно
(setvar "cmdecho" 0)
(vl-cmdf "_updatefield" txt "")
(princ "\n Укажите точку вставки текста или ячейку таблицы:")
(vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
;_ В txt примитив текста в pt точка вставки
(setq txt (entlast) pt (getvar "LASTPOINT"))
(or
(and ;_Проверяем, попала ли точка в ячейку таблицы
(setq tblobj nil tblset (ssget "_X" '((0 . "ACAD_TABLE"))))
(setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
(mapcar '(lambda (x)
(or tblobj
(and
(= :vlax-true (vla-HitTest x
(vlax-3d-point (trans pt 1 0))
(vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
'row 'col))
(setq tblobj x)
)
)
)
lst)
tblobj row col
(or (vla-SetText tblobj row col fld) t)
(entdel txt)
)
(and ;_Не попала, рисуем текст с полем
(setq txt (vlax-ename->vla-object txt))
(vlax-write-enabled-p txt)
(vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
(vlax-property-available-p txt 'TextString)
(vlax-put txt 'TextString fld)
)
)
)
(princ)
)

alex (2007-10-05 21:18:05)

Все работает корректно,спасибо!

alex (2007-10-11 20:24:38)

Александр!
Вопрос параллельно с VVA.
А можно ли суффикс и префикс писать другим фонтом, отдельным от числового значения?
Спасибо!

VVA (2007-10-17 10:00:33)

>alex (2007-10-11 20:24:38)
« А можно ли суффикс и префикс писать другим фонтом, отдельным от числового значения »

Нет, т.к. суффикс и префикс свойство поля. А там такой возможности не предусмотрено. Если бы суффикс был задан текстом (в мтексте) то проблем не вижу.
>iv (2007-10-11 11:50:47)
1. В опции установка заждай масштабный коэффициент 0.00001 или я не так понял?
2. Текст создается entmake. Для наклона нужно добавить поле 51 типа '(51 . 0.261799), где 0.261799 — угол наклона в радианах
Либо этот кусок кода

Код:

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

 
;_ Создаем текст
(setq txt (entmakex
(list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 72 0) ;_ выравнивание влево
(cons 1 fld)
;(cons 7 style) ;_Текущий стиль
;(cons 8 layer) ;_Текущий слой
(cons 10 '(0 0 0))
(cons 11 '(0 0 0))
(cons 40 *TEXTSIZE*) ;_Высота текста
) ;_ list
) ;_ entmakex
)

Засменить на этот

Код:

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

 
(setq tstyle (getvar "TEXTSTYLE")) ;_Стиль текста Стиль должен существовать
;_ Создаем текст
(if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
;; нулевая высота текста
(vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 fld)
(vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 fld)
) ;_ end of if
(setq txt (entlast))

Причем в этой строке
(getvar "TEXTSTYLE")) ;_Стиль текста Стиль должен существовать
можно задать свой УЖЕ СУЩЕСТВУЮЩИЙ стиль
типа
(setq tstyle "Стиль1")
3. Можно на кнопочке перед вызовом PAREATLB добавить что-то типа
_-LAYER;_M;Новый_слой_текста;PAREATLB и т.д.

[VVA]

Nata1, приложи файлик

[Nata1]

VVA, вот.

[VVA]

Nata1, Добавил форматирование (площадь, точность) и для всей формулы. См #2

[Nata1]

VVA, спасибо, стало гораздо удобнее. Только теперь вместо запятой всегда точка ставится, и при суммировании(вычитании) и без.
Точку сама исправила согласно поста 89
http://forum.dwg.ru/showpost.php?p=693051&postcount=89

[VVA]

Только теперь вместо запятой всегда точка ставится

Я уже писал в #139

Мне не понятно откуда в поле берется (разделитель - запятая) ... Я его в команде не формирую

Внес очередные изменения. Добавил в настройку разделитель. См. #2

[Nata1]

VVA, спасибо!

[esp1413]

Autocad 2012. Не работает:

Команда: _appload AreaToTab.lsp успешно загружено.
Команда:
Команда:
Команда: PAREATLB
Текущий масштаб = 1 Текущая точность округления = 2 Высота текста = 500.0
Префикс= Суффикс=
Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>:
Выберите полилинию, круг, сплайн, эллипс или дугу
Выберите объекты:
Найдено полей: 1.
Обновлено полей: 1.
Укажите точку вставки текста или ячейку таблицы:Неизвестная команда "NONE".
Для вызова справки нажмите F1.
*Прервано*

Прерывает после указания примитива.

Использовал вот это:

Код:

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

; Команда: PAREATLB
; Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы
; текст с полем (FIELD), содержащее значение площади построенного или выбранного контура.
; Точность округления и масштабный коэффициент настраиваются через опцию Установки
; Так как это поле связано с конкретным объектом, то при изменении
; объекта поле пересчитывается (необходимо обновление поля)
; Код можно сохранить в файле pareatlb.lsp
; Возможный макрос для кнопки или пункта меню:
; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;
;; Вариант макроса для задания м2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;м2;
;;Где
;; 0.001 — масштабный коэффициент
;; 2 — точность округления
;; 5 — высота текста
;; префикса нет
;; м2 — суффикс
;; Вариант макроса с использованием этого шрифта http://dwg.ru/dnl/147
;; Для м2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;/U+E738;
;; Для мм2
;; ^C^C(if (not C:PAREATLB) (load "pareatlb"));PAREATLB;S;0.001;2;5;;м/U+E738;
(defun C:PAREATLB ( / en cmdname fld txt fc tblset tblobj row col pt
whatAcadVer)
(defun whatAcadVer ( / Aver)2012)
(vl-load-com)
(or *SCALE* (setq *SCALE* 1))
(or *PREC* (setq *PREC* 2))
(or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
(or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
(setq *SUFF* (vl-princ-to-string *SUFF*))
(setq *PREF* (vl-princ-to-string *PREF*))
(princ "\nТекущий масштаб = ")(princ *SCALE*)
(princ " Текущая точность округления = ")(princ *PREC*)
(princ " Высота текста = ")(princ *TEXTSIZE*)
(princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
(initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
(and
(or ;_ > Проверяем версию
(> (whatAcadVer) 2005)
(alert "\nНужен Автокад версии 2006 и выше")
) ;_ < Проверяем версию
(or ;_ > Запрашиваем что рисовать + опции
(while (= (setq cmdname (getkword "\nВыберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: "))
"Setting")
(princ "\nНовый масштабный коэффициент <")(princ *SCALE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *SCALE* en))
(princ "\nТочность округления <")(princ *PREC*)(princ "> : ")
(initget 4)
(if (setq en (getint))(setq *PREC* en))
(princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *TEXTSIZE* en))
(princ "\nПрефикс (пробел — очистить) <")(princ *PREF*)(princ "> : ")
(if (= (setq en (getstring t)) " ")(setq en ""))
(if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
(setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
(princ "\nСуффикс (пробел — очистить) <")(princ *SUFF*)(princ "> : ")
(if (= (setq en (getstring t)) " ")(setq en ""))
(if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
(setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
(initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
)
t
) ;_ < Запрашиваем что рисовать + опции
(cond
((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
(while (> (getvar "CMDACTIVE") 0)(command pause))
(setq en (entlast))
)
((or (null cmdname)(= cmdname "sElect"))
(princ "\nВыберите полилинию, круг, сплайн, эллипс или дугу")
(and
(setq tblset (ssget "_:S:E" '((0 . "LINE,*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))))
(setq en (ssname tblset 0))
)
)
(t nil)
)
;_ Формируем поле
(setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string(vla-get-objectid (vlax-ename->vla-object en)))
">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
"]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
) ;_ strcat
) ;_ setq
;_ Создаем текст
(setq txt (entmakex
(list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 72 0) ;_ выравнивание влево
(cons 1 fld)
;(cons 7 style) ;_Текущий стиль
;(cons 8 layer) ;_Текущий слой
(cons 10 '(0 0 0))
(cons 11 '(0 0 0))
(cons 40 *TEXTSIZE*) ;_Высота текста
) ;_ list
) ;_ entmakex
)
;_ Копируем в буфер и обратно
(setvar "cmdecho" 0)
(vl-cmdf "_updatefield" txt "")
(princ "\n Укажите точку вставки текста или ячейку таблицы:")
(vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
;_ В txt примитив текста в pt точка вставки
(setq txt (entlast) pt (getvar "LASTPOINT"))
(or
(and ;_Проверяем, попала ли точка в ячейку таблицы
(setq tblobj nil tblset (ssget "_X" '((0 . "ACAD_TABLE"))))
(setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
(mapcar '(lambda (x)
(or tblobj
(and
(= :vlax-true (vla-HitTest x
(vlax-3d-point (trans pt 1 0))
(vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
'row 'col))
(setq tblobj x)
)
)
)
lst)
tblobj row col
(or (vla-SetText tblobj row col fld) t)
(entdel txt)
)
(and ;_Не попала, рисуем текст с полем
(setq txt (vlax-ename->vla-object txt))
(vlax-write-enabled-p txt)
(vlax-method-applicable-p txt 'FieldCode) ;_есть метод FieldCode
(vlax-property-available-p txt 'TextString)
(vlax-put txt 'TextString fld)
)
)
)
(princ)
)

[APavl]

Выберите полилинию, круг, сплайн, эллипс или дугу
Выберите объекты:
Найдено полей: 1.
Обновлено полей: 1.
Укажите точку вставки текста или ячейку таблицы:Неизвестная команда "NONE".
Для вызова справки нажмите F1.
*Прервано*
Прерывает после указания примитива.


Здравствуйте . Было то же самое . Как-то потом исчезло чудесным образом . Может даже после перезагрузки ... Как-то и не помню сейчас .

[owerty]

На основе PAREATLB хочу создать / изменить код, но нехватает знаний.
запросы от пользователя:

Масштабный коэффициент:
Количество десятичных знаков:
Округлять [Да/Нет] : (Да- стандартное округление, Нет- не округлять (отбросить лишние цифры / округлить в меньшую сторону)
Высота текста : 250
Подчеркивать текст [Да/Нет] :

Помогите, пожалуйста, разобраться с округлением

[skkkk]

Сообщение от owerty Помогите, пожалуйста, разобраться с округлением

Overty, хотелось бы для начала разобраться вот с этими несколькими пунктиками:
1. Что в данном контексте понимается под "стандартным округлением"? Текущее значение системной переменной или 2 знака или еще что-то?
2. Что же всё-таки должно происходить при нажатии Нет: "неокругление", отброс лишних цифр или округление в меньшую сторону? А может выпадение следующего меню со всеми этими пунктами?
3. Лишние цифры - это какие? Хвостовые нули? Или которые не помещаются куда-нибудь, в ячейку, например?
4. Округлить в меньшую сторону - это до меньшего целого или до стольких знаков, сколько указывает пользователь пунктом выше (Количество десятичных знаков:)?
А еще лучше изобразить бы непосредственно в dwg, например, как во вложении

[VVA]

esp1413,

Сообщение от esp1413 Autocad 2012. Не работает:

Проверю после выхода из отпуска
owerty, К вопросам skkkk мне пока добавить нечего.

[owerty]

-Количество десятичных знаков:
-Округлять [Да/Нет] :
Да- математическое округление к ближайшему "целому",
Нет- отбросить лишние цифры, следующие после количества, указанного в пред.запросе)

Чертеж2.dwg

[Nata1]

Уважаемый VVA, можно ли немного доработать лисп AREATT (вариант с суммированием/вычитанием площадей, чтобы можно было суммировать/вычитать площади объектов, образованных группой. Например, при подсчете площади помещения на плане, обвести контур помещения полилинией, а все колонны заранее сгруппировать командой GROUP и при запросе на выделение объекта сразу всю группу выделить, а не тыркать курсором в каждую колонну.

[VVA]

Тестируй. Можно группировать, можно выбирать рамкой/секрамкой
Предыдущие здесь

Код:

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

(defun C:ATTSS ( / en obj tblobj row col lst pt rows cols what fld str ss *error*)
;;;;  Команда: ATTSS (AREA To Table with Sum and Select)
;;;;  posted http://forum.dwg.ru/showthread.php?p=962978#post962978
;;;; Владимир Азарко (VVA) для www.dwg.ru
;;;; Вариант с суммированием, где при суммировании или вычитании используется выбор объектов ssget'ом.
;;;; Это дает возможность выбирать рамкой, секрамкой или группой, если объеты предварительно сруппировать командой _GROUP
;;;;  и включить группировку. Переменная PICKSTYLE=1 или сочетание клавиш CTRL+H
;;;;  Эта команда позволяет вставлять начиная с указанной ячейки таблицы
;;;;  текст с полем (FIELD), содержащее значение площади выбранного контура.
;;;;  В зависимости от выбора, навигация по таблице идет по строкам или столбцам.
;;;;  Если строки или столбцы заканчиваются, то они автоматически добавляются.
;;;;  Форматирование ячейки берется как у первой указанной.
;;;;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;;;;  Так как это поле связано с конкретным объектом, то при изменении
;;;;  объекта поле пересчитывается (необходимо обновление поля)
;;;;  Код можно сохранить в файле attss.lsp
;;;;  Возможный макрос для кнопки или пункта меню:
;;;;  ^C^C(if (not C:ATTSS)(load "ATTSS"));ATTSS;
  (vl-load-com)
(defun *error* (msg)(while (> (getvar "CMDACTIVE") 0) (command))
 (princ message)(princ))
  (or *SCALE* (setq *SCALE* 1))
  (or *PREC* (setq *PREC* 2))
  (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
  (or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
  (setq *SUFF* (vl-princ-to-string *SUFF*))
  (setq *PREF* (vl-princ-to-string *PREF*))
  (princ "\nТекущий масштаб = ")(princ *SCALE*)
  (princ " Текущая точность округления = ")(princ *PREC*)
  (princ " Высота текста = ")(princ *TEXTSIZE*)
  (princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
  (princ " Разделитель=")(princ (if *DSEP* "запятая" "точка"))
  ;;;(setq  tblobj nil tblobj (ssget "_X" '((0 . "ACAD_TABLE"))))
  (and
  (setq  tblobj nil tblobj (ssget "_X" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
  (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblobj)))))
  )
  (setq  tblobj nil)
  (cond
   ((and lst
         (or (initget "Row Col Setting стРоки сТолбцы Установки _Row Col Setting Row Col Setting") t)
         (or (while (=(setq what (getkword "\nПеремещаться [по стРокам/по сТолбцам/Установки] <по сТолбцам>: "))
                      "Setting")
                     (princ "\nНовый масштабный коэффициент <")(princ *SCALE*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *SCALE* en))
      (princ "\nТочность округления <")(princ *PREC*)(princ "> : ")
      (initget 4)
      (if (setq en (getint))(setq *PREC* en))
      (princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *TEXTSIZE* en))
      (princ "\nПрефикс (пробел - очистить) <")(princ *PREF*)(princ "> : ")
      (if (= (setq en (getstring t)) " ")(setq en ""))
      (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
      (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
      (princ "\nСуффикс (пробел - очистить) <")(princ *SUFF*)(princ "> : ")
      (if (= (setq en (getstring t)) " ")(setq en ""))
      (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
      (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
      (princ (strcat "\nРазделитель дробной части [Точка/Запятая] <"(if *DSEP* "запятая" "точка")">:"))
      (initget "Точка Запятая")
      (setq en (getkword))
      (cond ((eq en "Запятая")(setq *DSEP* t))((eq en "Точка")(setq *DSEP* nil))(t nil))
               (initget "Row Col Setting стРоки сТолбцы Установки _Row Col Setting Row Col Setting")
               )
             t
             )
         (or what (setq what "Col"))
         (or
        (while (null  tblobj)
          (initget 1)
          (setq pt (getpoint "\nУкажите ячейку таблицы:"))
          (mapcar '(lambda (x)
           (or tblobj
               (and
                 (= :vlax-true (vla-HitTest x
                               (vlax-3d-point (trans pt 1 0))
                               (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                               'row 'col))
                 (setq tblobj x)
                 )
               )
           )
        lst)
          (if (null  tblobj)(princ " ** мимо **"))
          )
        t)
         (or
           (vlax-write-enabled-p tblobj)
           (and
             (princ "\nТаблица на заблокированном слое!")
             nil
             )
           )
         (setq pt (vla-GetCellAlignment tblobj row col))
         )
    (setq rows (vla-get-rows tblobj))
    (setq cols (vla-get-columns tblobj))
    (initget "+ -")
    (while (setq en (entsel "\nВыберите примитив для вставки его площади в таблицу (+ сумма; - вычитание; ENTER — завершение): " ))
      (if (listp en)(setq en (car en)))
      (setq fld nil)
      (cond
       ((and (member en '("+" "-"))
             (setq ss (mip-ssentget-by-type (strcat (if (= en "+") "СУММИРОВАНИЕ > " "ВЫЧИТАНИЕ > ") "Выбери полилинию") '("LWPOLYLINE" "CIRCLE") 14))
             )
	(setq str en fld "%<\\AcExpr (" lst (lib:conv-pickset-to-list ss))
        (foreach en lst
	  (if (vlax-property-available-p (setq en (vlax-ename->vla-object en)) 'Area)
	    (progn
	      (vla-Highlight en :vlax-true)
	   (setq fld (strcat fld "%<\\AcObjProp Object(%<\\_ObjId "
             (vl-princ-to-string(Get-ObjectID-x86-x64 en))
                ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr"(itoa *PREC*)(if *DSEP* "%ds44" "") "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
		str	     
                ) ;_ strcat
		 )
	   )
	    (princ "\nДля этого примитива невозможно получить свойство Area!")
	    )
	  )
	(mapcar '(lambda(x)(vla-Highlight x :vlax-false)) (mapcar 'vlax-ename->vla-object lst))
	(setq fld (strcat (vl-string-right-trim str fld) ") \\f \"%lu2%ps["*PREF* "," *SUFF* 
                "]%pr"(itoa *PREC*)(if *DSEP* "%ds44" "") "%ct8["(vl-princ-to-string *SCALE*)"]\">%"))
	)
       ((vlax-property-available-p (setq en (vlax-ename->vla-object en)) 'Area)
          (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
             (vl-princ-to-string(Get-ObjectID-x86-x64 en))
                ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr"(itoa *PREC*)(if *DSEP* "%ds44" "") "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
                ) ;_ strcat
          )
       )
       (t(princ "\nДля этого примитива невозможно получить свойство Area!"))
      )
      (if (= (type fld) 'STR)
	(progn
	  (cond
          ((= col cols)
            (vla-insertColumns tblobj col (vla-GetColumnWidth tblobj (1- col)) 1)
            (vla-SetCellAlignment tblobj row col pt)
            (setq rows (vla-get-rows tblobj))
            (setq cols (vla-get-columns tblobj))
            
          )
          ((= row rows)
            (vla-insertRows tblobj row (vla-GetRowHeight tblobj (1- row)) 1)
           (vla-SetCellAlignment tblobj row col pt)
            (setq rows (vla-get-rows tblobj))
            (setq cols (vla-get-columns tblobj))
         )
          (t nil))
        (vla-SetText tblobj row col fld)
        (if (= what "Col")(setq col (1+ col))(setq row (1+ row)))
	  )
	)
     (initget "+ -")
    )
   )
   (t
     (princ "\nТаблиц не найдено!")
   )
  )
  (princ)
)
(defun mip-ssentget-by-type (msg types bits / sel cmd_lst) 
;;; 
;;; Параметры: 
;;; msg - краткое приглашение для выбора, допускается NIL 
;;; bits - целое от 0 до 15, битовый переключатель, значения битов: 
;;;    1 - разрешение выбора на заблокированном слое 
;;;    2 - разрешение многократного выбора 
;;;    4 - разрешение выбора рамкой / секрамкой 
;;;    8 - возвращать набор 
;;; types - список имен допустимых типов примитивов, допускается NIL 
;;; 
;;; Пример: 
;;; (mip-ssentget-by-type "Выбери отрезок или полилинию" '("LINE" "LWPOLYLINE") 14) 
;;; 
;;; Возвращает имя _первого_ примитива из попавших в набор, при удачном выборе 
;;; или NIL при отказе с помощью Enter или прерывании по Esc, в последнем случае, 
;;; одновременно выводит сообщение о прерывании в командную строку. 
;;; 
;;; При наличииии любого из битов: 2, 4 или 8 и при успешном выборе, возвращает 
;;; не имя примитива, а набор. 
;;; 
  (setq msg     (strcat "\n" 
                        (if msg 
                          (strcat msg " ") 
                          "" 
                        ) 
                        (if (= (strcase (getvar "SYSCODEPAGE")) "ANSI_1251") 
                          "<Выход>" 
                          "<Exit>" 
                        ) 
                ) 
        cmd_lst (if (= (logand bits 2) 0) 
                  ":S" 
                  "" 
                ) 
        cmd_lst (if (= (logand bits 4) 0) 
                  (strcat cmd_lst ":E") 
                  cmd_lst 
                ) 
        cmd_lst (if (= (logand bits 1) 0) 
                  (strcat cmd_lst ":L") 
                  cmd_lst 
                ) 
        cmd_lst (if (/= cmd_lst "") 
                  (list (strcat "_" cmd_lst)) 
                ) 
        types   (mapcar (function (lambda (x) (cons 0 x))) types) 
  ) 
  (if (and types (> (length types) 1)) 
    (setq types (append (cons '(-4 . "<OR") types) '((-4 . "OR>")))) 
  ) 
  (if types 
    (setq cmd_lst (append cmd_lst (list types))) 
  ) 
  (setvar "ERRNO" 0) 
  (while (and (/= (getvar "ERRNO") 52) (not sel)) 
    (princ msg) 
    (setvar "nomutt" 1) 
    (vl-catch-all-error-p (setq sel (vl-catch-all-apply 'ssget cmd_lst))) 
    (setvar "nomutt" 0) 
    (if (and (not sel) (= (logand bits 2) 2)) 
      (setq sel t) 
    ) 
  ) 
  (cond ((not sel) nil) 
        ((= (type sel) 'pickset) 
         (if (= (logand bits 14) 0)
           (ssname sel 0) 
           sel 
         ) 
        ) 
        ((= (type sel) 'vl-catch-all-apply-error) (princ (vl-catch-all-error-message sel)) nil) 
        (t nil) 
  ) 
)
(defun lib:conv-pickset-to-list (value / item lst)
       (repeat (setq item (sslength value)) ;_ end setq
         (setq lst (cons (ssname value (setq item (1- item))) lst))
         ) ;_ end repeat

  lst
;;;  (if selset 
;;;    (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))) 
;;;    )
  ) ;_ end of defun 
;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961
;; http://forum.dwg.ru/showthread.php?t=51822
;;--------------------------------------------------------
(defun Get-ObjectID-x86-x64 (obj / util)
  (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (if (= (type obj) 'VLA-OBJECT)
     (if (> (vl-string-search "x64" (getvar "platform")) 0)
       (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
       (rtos (vla-get-objectid obj) 2 0)
     )
  )
)

[AlexV]

Уважаемый VVA, вы мастер лиспописания и и к тому же программного полезабивания в таблицы автокада.. А не могли бы вы сочинить лисп, принудительно обновляющий поля в таблице?

[VVA]

?

Код:

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

(command "_updatefield" "_all" "")

[AlexV]

Сообщение от VVA ? Код: [Выделить все] (command "_updatefield" "_all" "")

Ежели б усе было так просто.. Не работает, зараза, "апдейтофилд все"! По непонятной причине перестают обновляться поля в таблицах, обновляются только при заходе в ячейку, в редактор поля и нажатии кнопки "ОК". Вот я и думаю, может возможно написать код, "симулирующий" это действие?

[Largo GT]

Сообщение от VVA Тестируй. Можно группировать, можно выбирать рамкой/секрамкой Предыдущие здесь Код: [Выделить все] (defun C:ATTSS ( / en obj tblobj row col lst pt rows cols what fld str ss *error*) ;;;; Команда: ATTSS (AREA To Table with Sum and Select) ;;;; posted http://forum.dwg.ru/showthread.php?p=962978#post962978 ;;;; Владимир Азарко (VVA) для www.dwg.ru ;;;; Вариант с суммированием, где при суммировании или вычитании используется выбор объектов ssget'ом. ;;;; Это дает возможность выбирать рамкой, секрамкой или группой, если объеты предварительно сруппировать командой _GROUP ;;;; и включить группировку. Переменная PICKSTYLE=1 или сочетание клавиш CTRL+H ;;;; Эта команда позволяет вставлять начиная с указанной ячейки таблицы ;;;; текст с полем (FIELD), содержащее значение площади выбранного контура. ;;;; В зависимости от выбора, навигация по таблице идет по строкам или столбцам. ;;;; Если строки или столбцы заканчиваются, то они автоматически добавляются. ;;;; Форматирование ячейки берется как у первой указанной. ;;;; Точность округления и масштабный коэффициент настраиваются через опцию Установки ;;;; Так как это поле связано с конкретным объектом, то при изменении ;;;; объекта поле пересчитывается (необходимо обновление поля) ;;;; Код можно сохранить в файле attss.lsp ;;;; Возможный макрос для кнопки или пункта меню: ;;;; ^C^C(if (not C:ATTSS)(load "ATTSS"));ATTSS; (vl-load-com) (defun *error* (msg)(while (> (getvar "CMDACTIVE") 0) (command)) (princ message)(princ)) (or *SCALE* (setq *SCALE* 1)) (or *PREC* (setq *PREC* 2)) (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE"))) (or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* "")) (setq *SUFF* (vl-princ-to-string *SUFF*)) (setq *PREF* (vl-princ-to-string *PREF*)) (princ "\nТекущий масштаб = ")(princ *SCALE*) (princ " Текущая точность округления = ")(princ *PREC*) (princ " Высота текста = ")(princ *TEXTSIZE*) (princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*) (princ " Разделитель=")(princ (if *DSEP* "запятая" "точка")) ;;;(setq tblobj nil tblobj (ssget "_X" '((0 . "ACAD_TABLE")))) (and (setq tblobj nil tblobj (ssget "_X" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB"))))) (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblobj))))) ) (setq tblobj nil) (cond ((and lst (or (initget "Row Col Setting стРоки сТолбцы Установки _Row Col Setting Row Col Setting") t) (or (while (=(setq what (getkword "\nПеремещаться [по стРокам/по сТолбцам/Установки] <по сТолбцам>: ")) "Setting") (princ "\nНовый масштабный коэффициент <")(princ *SCALE*)(princ "> : ") (initget 6) (if (setq en (getdist))(setq *SCALE* en)) (princ "\nТочность округления <")(princ *PREC*)(princ "> : ") (initget 4) (if (setq en (getint))(setq *PREC* en)) (princ "\nВысота текста <")(princ *TEXTSIZE*)(princ "> : ") (initget 6) (if (setq en (getdist))(setq *TEXTSIZE* en)) (princ "\nПрефикс (пробел - очистить) <")(princ *PREF*)(princ "> : ") (if (= (setq en (getstring t)) " ")(setq en "")) (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+") (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en) (princ "\nСуффикс (пробел - очистить) <")(princ *SUFF*)(princ "> : ") (if (= (setq en (getstring t)) " ")(setq en "")) (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+") (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en) (princ (strcat "\nРазделитель дробной части [Точка/Запятая] <"(if *DSEP* "запятая" "точка")">:")) (initget "Точка Запятая") (setq en (getkword)) (cond ((eq en "Запятая")(setq *DSEP* t))((eq en "Точка")(setq *DSEP* nil))(t nil)) (initget "Row Col Setting стРоки сТолбцы Установки _Row Col Setting Row Col Setting") ) t ) (or what (setq what "Col")) (or (while (null tblobj) (initget 1) (setq pt (getpoint "\nУкажите ячейку таблицы:")) (mapcar '(lambda (x) (or tblobj (and (= :vlax-true (vla-HitTest x (vlax-3d-point (trans pt 1 0)) (vlax-3d-point (trans (getvar "VIEWDIR") 1 0)) 'row 'col)) (setq tblobj x) ) ) ) lst) (if (null tblobj)(princ " ** мимо **")) ) t) (or (vlax-write-enabled-p tblobj) (and (princ "\nТаблица на заблокированном слое!") nil ) ) (setq pt (vla-GetCellAlignment tblobj row col)) ) (setq rows (vla-get-rows tblobj)) (setq cols (vla-get-columns tblobj)) (initget "+ -") (while (setq en (entsel "\nВыберите примитив для вставки его площади в таблицу (+ сумма; - вычитание; ENTER — завершение): " )) (if (listp en)(setq en (car en))) (setq fld nil) (cond ((and (member en '("+" "-")) (setq ss (mip-ssentget-by-type (strcat (if (= en "+") "СУММИРОВАНИЕ > " "ВЫЧИТАНИЕ > ") "Выбери полилинию") '("LWPOLYLINE" "CIRCLE") 14)) ) (setq str en fld "%<\\AcExpr (" lst (lib:conv-pickset-to-list ss)) (foreach en lst (if (vlax-property-available-p (setq en (vlax-ename->vla-object en)) 'Area) (progn (vla-Highlight en :vlax-true) (setq fld (strcat fld "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 en)) ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF* "]%pr"(itoa *PREC*)(if *DSEP* "%ds44" "") "%ct8["(vl-princ-to-string *SCALE*)"]\">%" str ) ;_ strcat ) ) (princ "\nДля этого примитива невозможно получить свойство Area!") ) ) (mapcar '(lambda(x)(vla-Highlight x :vlax-false)) (mapcar 'vlax-ename->vla-object lst)) (setq fld (strcat (vl-string-right-trim str fld) ") \\f \"%lu2%ps["*PREF* "," *SUFF* "]%pr"(itoa *PREC*)(if *DSEP* "%ds44" "") "%ct8["(vl-princ-to-string *SCALE*)"]\">%")) ) ((vlax-property-available-p (setq en (vlax-ename->vla-object en)) 'Area) (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 en)) ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF* "]%pr"(itoa *PREC*)(if *DSEP* "%ds44" "") "%ct8["(vl-princ-to-string *SCALE*)"]\">%" ) ;_ strcat ) ) (t(princ "\nДля этого примитива невозможно получить свойство Area!")) ) (if (= (type fld) 'STR) (progn (cond ((= col cols) (vla-insertColumns tblobj col (vla-GetColumnWidth tblobj (1- col)) 1) (vla-SetCellAlignment tblobj row col pt) (setq rows (vla-get-rows tblobj)) (setq cols (vla-get-columns tblobj)) ) ((= row rows) (vla-insertRows tblobj row (vla-GetRowHeight tblobj (1- row)) 1) (vla-SetCellAlignment tblobj row col pt) (setq rows (vla-get-rows tblobj)) (setq cols (vla-get-columns tblobj)) ) (t nil)) (vla-SetText tblobj row col fld) (if (= what "Col")(setq col (1+ col))(setq row (1+ row))) ) ) (initget "+ -") ) ) (t (princ "\nТаблиц не найдено!") ) ) (princ) ) (defun mip-ssentget-by-type (msg types bits / sel cmd_lst) ;;; ;;; Параметры: ;;; msg - краткое приглашение для выбора, допускается NIL ;;; bits - целое от 0 до 15, битовый переключатель, значения битов: ;;; 1 - разрешение выбора на заблокированном слое ;;; 2 - разрешение многократного выбора ;;; 4 - разрешение выбора рамкой / секрамкой ;;; 8 - возвращать набор ;;; types - список имен допустимых типов примитивов, допускается NIL ;;; ;;; Пример: ;;; (mip-ssentget-by-type "Выбери отрезок или полилинию" '("LINE" "LWPOLYLINE") 14) ;;; ;;; Возвращает имя _первого_ примитива из попавших в набор, при удачном выборе ;;; или NIL при отказе с помощью Enter или прерывании по Esc, в последнем случае, ;;; одновременно выводит сообщение о прерывании в командную строку. ;;; ;;; При наличииии любого из битов: 2, 4 или 8 и при успешном выборе, возвращает ;;; не имя примитива, а набор. ;;; (setq msg (strcat "\n" (if msg (strcat msg " ") "" ) (if (= (strcase (getvar "SYSCODEPAGE")) "ANSI_1251") "<Выход>" "<Exit>" ) ) cmd_lst (if (= (logand bits 2) 0) ":S" "" ) cmd_lst (if (= (logand bits 4) 0) (strcat cmd_lst ":E") cmd_lst ) cmd_lst (if (= (logand bits 1) 0) (strcat cmd_lst ":L") cmd_lst ) cmd_lst (if (/= cmd_lst "") (list (strcat "_" cmd_lst)) ) types (mapcar (function (lambda (x) (cons 0 x))) types) ) (if (and types (> (length types) 1)) (setq types (append (cons '(-4 . "<OR") types) '((-4 . "OR>")))) ) (if types (setq cmd_lst (append cmd_lst (list types))) ) (setvar "ERRNO" 0) (while (and (/= (getvar "ERRNO") 52) (not sel)) (princ msg) (setvar "nomutt" 1) (vl-catch-all-error-p (setq sel (vl-catch-all-apply 'ssget cmd_lst))) (setvar "nomutt" 0) (if (and (not sel) (= (logand bits 2) 2)) (setq sel t) ) ) (cond ((not sel) nil) ((= (type sel) 'pickset) (if (= (logand bits 14) 0) (ssname sel 0) sel ) ) ((= (type sel) 'vl-catch-all-apply-error) (princ (vl-catch-all-error-message sel)) nil) (t nil) ) ) (defun lib:conv-pickset-to-list (value / item lst) (repeat (setq item (sslength value)) ;_ end setq (setq lst (cons (ssname value (setq item (1- item))) lst)) ) ;_ end repeat lst ;;; (if selset ;;; (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))) ;;; ) ) ;_ end of defun ;;-------------------------------------------------------- ;; Функция получает строковое представление ObjectID ;; вне зависимости от того AutoCAD x86 или x64 ;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961 ;; http://forum.dwg.ru/showthread.php?t=51822 ;;-------------------------------------------------------- (defun Get-ObjectID-x86-x64 (obj / util) (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object)))) (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj))) (if (= (type obj) 'VLA-OBJECT) (if (> (vl-string-search "x64" (getvar "platform")) 0) (vlax-invoke-method util "GetObjectIdString" obj :vlax-False) (rtos (vla-get-objectid obj) 2 0) ) ) )

у меня абракадабра :

Код:

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

Команда: ATTSS

Текущий масштаб = 1 Текущая точность 
округления = 2 Высота текста = 280.0 Префикс=  
Суффикс=  Р*азделитель=точка
Таблиц не найдено!

Команда:

ACA 2012 x64 rus sp2

[VVA]

AlexV, покажи файл, а так же расскажи про автокад и винду поподробнее
>Largo GT такое бывает, когда копируешь код при текущей английской раскладке.

[AlexV]

Сообщение от VVA AlexV, покажи файл, а так же расскажи про автокад и винду поподробнее >Largo GT такое бывает, когда копируешь код при текущей английской раскладке.

Винда "7" 64 бит, иногда работаю под виртуалкой "win xp-mode". Автокад 2012 + SPDS CS (сборка 7.1.1064), - но та же ерунда бывала и на других версиях (2010, 2011). Глюк не постоянный, в новом файле обычно все окей. Когда возникает, с чем связан, - не знаю.. Вроде связан с файлом, а не компом, - на других открываешь файл, - глюк остается.