[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]

;;;; Команда: AREATT (AREA To Table) ;;;; posted http://dwg.ru/f/showthread.php?t=14528 ;;;; Эта команда позволяет вставлять начиная с указанной ячейки таблицы ;;;; текст с полем (FIELD), содержащее значение площади выбранного контура. ;;;; В зависимости от выбора, навигация по таблице идет по строкам или столбцам. ;;;; Если строки или столбцы заканчиваются, то они автоматически добавляются. ;;;; Форматирование ячейки берется как у первой указанной. ;;;; Точность округления и масштабный коэффициент настраиваются через опцию Установки ;;;; Так как это поле связано с конкретным объектом, то при изменении ;;;; объекта поле пересчитывается (необходимо обновление поля) ;;;; Код можно сохранить в файле areatt.lsp ;;;; Возможный макрос для кнопки или пункта меню: ;;;; ^C^C(if (not C:AREATT)(load "AREATT"));AREATT;

Спасибо Владимир Громов (Profan на этом форуме) что начал потихоньку вытаскивать интересные темы. Мне показалась интересной идея Незнайки

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

Но пока до нее дошли руки, autocad.ru начало колбасить. Продолжаю тему здесь.
Кратко суть работы:
Щелчком мыши внутри указываешь с какой ячейки таблицы начинать, выбираешь способ навигации (по строкам или столбцам), далее выбираешь объекты и их площади автоматом попадают в соответствии с установками и выбранным способом навигации в соответствующие строки или столбцы таблицы. Если строки или столбцы заканчиваются, то они добавляются.

Код:

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

;  Команда: AREATT (AREA To Table)
;  posted http://dwg.ru/f/showthread.php?t=14528
;  Эта команда позволяет вставлять начиная с указанной ячейки таблицы
;  текст с полем (FIELD), содержащее значение площади выбранного контура.
;  В зависимости от выбора, навигация по таблице идет по строкам или столбцам.
;  Если стороки или столбцы заканчиваются, то они автоматически добавляются.
;  Форматирование ячейки берется как у первой указанной.
;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;  Так как это поле связано с конкретным объектом, то при изменении
;  объекта поле пересчитывается (необходимо обновление поля)
;  Код можно сохранить в файле areatt.lsp
;  Возможный макрос для кнопки или пункта меню:
;  ^C^C(if (not C:AREATT)(load "AREATT"));AREATT;

(defun C:AREATT ( / en obj tblobj row col lst pt rows cols what fld)
  (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*)
 (and
  (setq  tblobj nil tblobj (ssget "_X" '((0 . "ACAD_TABLE"))))
  (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)
               (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))
    (while (setq en (car (entsel "\nВыберите примитив для вставки его площади в таблицу (ENTER — завершение): " )))
      (cond
       ((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*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
                ) ;_ strcat
          )
        (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)))
        
       )
       (t(princ "\nДля этого примитива невозможно получить свойство Area!"))
      )
      
    )
   )
   (t
     (princ "\nТаблиц не найдено!")
   )
  )
  (princ)
)

;;--------------------------------------------------------
;; Функция получает строковое представление 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)
     )
  )
)

Обновлено 2012-05-16

Код:

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

;;; Вариант с суммированием
;;;;  Команда: AREATT (AREA To Table)
;;;;  posted http://dwg.ru/f/showthread.php?t=14528
;;;;  Эта команда позволяет вставлять начиная с указанной ячейки таблицы
;;;;  текст с полем (FIELD), содержащее значение площади выбранного контура.
;;;;  В зависимости от выбора, навигация по таблице идет по строкам или столбцам.
;;;;  Если строки или столбцы заканчиваются, то они автоматически добавляются.
;;;;  Форматирование ячейки берется как у первой указанной.
;;;;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;;;;  Так как это поле связано с конкретным объектом, то при изменении
;;;;  объекта поле пересчитывается (необходимо обновление поля)
;;;;  Код можно сохранить в файле areatt.lsp
;;;;  Возможный макрос для кнопки или пункта меню:
;;;;  ^C^C(if (not C:AREATT)(load "AREATT"));AREATT;
;;;; 16.05.2012 Добавлена настройка разделителя (точка запятая)

(defun C:AREATT ( / en obj tblobj row col lst pt rows cols what fld str)
  (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*)
  (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
       ((member en '("+" "-"))
	(setq str en fld "%<\\AcExpr (" lst nil)
	(while (setq en (car(entsel
			  (strcat "\n" (if (= str "+") "СУММИРОВАНИЕ > " "ВЫЧИТАНИЕ > ")
					 "Выберите примитив для вставки его площади в таблицу (ENTER — завершение): " ))
		     ))
	  (if (vlax-property-available-p (setq en (vlax-ename->vla-object en)) 'Area)
	    (progn
	      (setq lst (cons en lst))
	      (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)) 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)
)
;;--------------------------------------------------------
;; Функция получает строковое представление 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)
     )
  )
)

Вариант, где при суммировании или вычитании используется выбор объектов ssget'ом.
Это дает возможность выбирать рамкой, секрамкой или группой, если объекты предварительно сгруппировать командой _GROUP
Остальное здесь: ATTSS (AREA To Table with Sum and Select))

[VVA]

Вариант команды PAREATLB вставляет в таблицу тест с длиной примитива или площадью

Код:

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

;  Команда: PTLB
;  Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы
;  текст с полем (FIELD), содержащее значение площади или длины построенного или выбранного контура.
;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;  Так как это поле связано с конкретным объектом, то при изменении
;  объекта поле пересчитывается (необходимо обновление поля)
;  Код можно сохранить в файле ptlb.lsp
;  Возможный макрос для кнопки или пункта меню:
;  ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;
;; Вариант макроса для задания м2
;; ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;_L;_S;1;0.001;2;3;5;;м2;
;;Где
;; _L - считать длинну (_A - площадь)
;; _S - установки
;; 1 - линейный масштабный коэффициент
;; 0.001 — площадной масштабный коэффициент
;; 2 — точность представления чисел
;; 3 - Кратность округления (0-Нет)
;; 5 — высота текста
;; префикса нет
;; м2 - суффикс

(defun C:PTLB ( / en cmdname fld txt fc tblset tblobj row col pt
                 whatAcadVer tstyle what *error* layer-status-save
               layer-status-restore
               )
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008
(defun whatAcadVer ( / Aver)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.2) 2012)  
((= Aver 18.1) 2011)  
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2013)
)
)
  (defun _round (num prec)
  (cond ((zerop prec) num)
        (t
         (* prec
            (if (minusp num)
              (fix (- (/ num prec) 0.5))
              (fix (+ (/ num prec) 0.5))
              )
            )
         )
        )
)
  (defun *error* (msg)(layer-status-restore)
    (princ msg)(princ))
  (defun layer-status-save ()
    (setq *MIP_LAYER_LST* nil)
    (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 
      (setq *MIP_LAYER_LST* (cons (list item 
                                  (cons "lock" (vla-get-lock item)) 
                                  ) ;_ end of cons 
                            *MIP_LAYER_LST* 
                            ) ;_ end of cons 
            ) ;_ end of setq 
      (vla-put-lock item :vlax-false)
      ) ;_ end of vlax-for
      
    );_ end of defun
(defun layer-status-restore () 
    (foreach item *MIP_LAYER_LST*
      (if (not (vlax-erased-p (car item))) 
        (vl-catch-all-apply 
          '(lambda () 
             (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
             ) ;_ end of lambda 
          ) ;_ end of vl-catch-all-apply 
        ) ;_ end of if 
      ) ;_ end of foreach
    (setq *MIP_LAYER_LST* nil)
    ) ;_ end of defun 
  (vl-load-com)
  (or *SCALEL* (setq *SCALEL* 1))
  (or *SCALEA* (setq *SCALEA* 1))
  (or *PREC* (setq *PREC* 2))
  (or *OKR* (setq *OKR* 0))
  (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*))
  (and
    (or ;_ > Проверяем версию
      (> (whatAcadVer) 2005)
      (alert "\nНужен Автокад версии 2006 и выше")
      ) ;_ < Проверяем версию
    (or (initget "Length Area Длина Площадь _Length Area Length Area") t)
    (if (null (setq what (getkword "\nЧто будем считать [Длина/Площадь] <Длина> :")))
      (setq what "Length") t)
      (princ "\nТекущий масштаб: линейный = ")(princ *SCALEL*)(princ " площадной = ")(princ *SCALEA*)
      (princ " Точность = ")(princ *PREC*)
      (princ " Кратность округления =")(princ (if (zerop *OKR*) "нет" *OKR*))
      (princ " Высота текста = ")(princ *TEXTSIZE*)
      (princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*)
    (or
      (initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect")
      t
      )
    (or ;_ > Запрашиваем что рисовать + опции
    (while (= (setq cmdname (getkword (strcat (if (= what "Area") "\n<Площадь> " "\n<Длина> ")
           "Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: ")))
              "Setting")
      (princ "\nНовый линейный масштабный коэффициент <")(princ *SCALEL*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *SCALEL* en))
      (princ "\nНовый площадной масштабный коэффициент <")(princ *SCALEA*)(princ "> : ")
      (initget 6)
      (if (setq en (getdist))(setq *SCALEA* en))
      (princ "\nТочность представления чисел <")(princ *PREC*)(princ "> : ")
      (initget 4)
      (if (setq en (getint))(setq *PREC* en))
      (princ "Кратность округления (0-Нет) <")(princ (if (zerop *OKR*) "нет" *OKR*))(princ "> : ")
      (initget 4)
      (if (setq en (getreal))(setq *OKR* 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
    ) ;_ < Запрашиваем что рисовать + опции
   (or (layer-status-save) 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" (if (= what "Area") '((0 . "*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))
                                                           '((0 . "LINE,*POLYLINE,ARC,CIRCLE")))
                                         ))
           (setq en (ssname tblset 0))
           )
     )
    (t nil)
    )
  ;_ Формируем поле
  (cond
    ((= what "Area")
     (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
             (vl-princ-to-string(Get-ObjectID-x86-x64 (vlax-ename->vla-object en)))
                ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEA*)"]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (= (cdr(assoc 0 (entget en))) "CIRCLE")
          )
     (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (Get-ObjectID-x86-x64 (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Circumference \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEA*)"]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (= (cdr(assoc 0 (entget en))) "ARC")
          )
     (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (Get-ObjectID-x86-x64 (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).ArcLength \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEA*)"]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    ((and (= what "Length")
          (vlax-property-available-p (vlax-ename->vla-object en) "Length")
          )
     (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (Get-ObjectID-x86-x64 (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Length \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEA*)"]\">%"
                ) ;_ strcat
          ) ;_ setq
     )
    (t (setq fld "Неизвестное свойство"))
    )
;;;Округляем
   (if (not (zerop *OKR*))
     (setq fld
            (strcat
              "%<\\AcExpr ((Trunc("
              (substr fld 1 (1-(vl-string-search "\\f" fld)))
              ">%"
              " / "
              (vl-prin1-to-string *OKR*)
              " + 0.5"
              "))*"
              (vl-prin1-to-string *OKR*)
              ")"
              (substr fld (vl-string-search "\\f" fld))
              ;;">%"
              )
           )
     t
     )
(setvar "cmdecho" 0)
(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))
  ;_ Копируем в буфер и обратно
  (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" (list '(0 . "ACAD_TABLE")(cons 410 (getvar "CTAB")))))
      (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
      (progn
        (vl-catch-all-apply '(lambda()
        (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)
      )
    )
  )
  (layer-status-restore)
  (princ)
  )
(princ "\nКоманда PTLB. Версия от 20.04.2011 http://forum.dwg.ru/showpost.php?p=183237&postcount=3")
(princ)

;;--------------------------------------------------------
;; Функция получает строковое представление 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)
     )
  )
)
(princ "\nКоманда PTLB. Версия от 19.03.2012 http://forum.dwg.ru/showpost.php?p=183237&postcount=3")
(princ)

Еще ссылки
Вариант PAREATLB с подчеркиванием
MAREATT
исправленная PAREATLB из #1
Вариант PTLB для мебели (BOXTLB)
Вариант PTLB для размеров (DIMTLB)

[gabrin]

Очень интересная тема. Давно бъюсь над задачей ( как раз в тему топика ). При проектировании мои полилинии имеют несколько ключевых для меня свойств - это слой, тип линии,длина и значение Z. Никак не удается написать лисп , который рисовал бы таблицу из 4-х строк, в которой бы в "Поле" вписывал эти самые ключевые свойства. Если кто знает как это можно осуществить, буду весьма признателен.

[VVA]

Полилинии какие: LWPOLYLINE, 2DPOLYLINE, 3DPOLYLINE. От этого зависит, где искать координату Z
Сами поля для твоих свойств

Код:

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

(setq *PREC* 2) ;_точность округления
(setq *SCALEL* 1);_масштабный коэффициент
(vl-load-com)
(defun C:TEST ()
(if  
(and
  (setq en (car(entsel "\nУкажи полилинию")))
  (= (cdr(assoc 0 (entget en))) "LWPOLYLINE")
  )
(progn
;;Длина
(setq fld_Len (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Length \\f \"%lu2%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEL*)"]\">%"
                ) ;_ strcat
          ) ;_ setq
;;Уровень (Z)
(setq fld_Z (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Elevation \\f \"%lu2%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEL*)"]\">%"
                ) ;_ strcat
          ) ;_ setq

;;Слой
(setq fld_lay (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Layer>%"
                ) ;_ strcat
          ) ;_ setq

;;Тип линии
(setq fld_LT (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Linetype>%"
                ) ;_ strcat
          ) ;_ setq
(princ "\nПоле-длина: ")(princ fld_len)
(princ "\nПоле-уровень: ")(princ fld_Z)  
(princ "\nПоле-слой: ")(princ fld_lay)
(princ "\nПоле-тип линии: ")(princ fld_lt)
)
(princ "\Объект не полилиния")
)
(princ)
  )

[gabrin]

В моем случае я использую 3DPolyline

[gabrin]

Хороший Лисп, как раз то что нужно. Последний вопрос- Как сделать чтобы все это выводилось в одну таблицу на экран?

[VVA]

Сообщение от gabrin В моем случае я использую 3DPolyline

У 3d полилинии нет свойства "Уровень", соответственно полем на координату Z не сослаться

[gabrin]

Сообщение от VVA У 3d полилинии нет свойства "Уровень", соответственно полем на координату Z не сослаться

Дело в том что я пользуюсь Лиспом прокладки 3DPolyline на разных отметках с опусками и подъемами. С уровнем я уже понял. Возможно переделать ваш Лисп под 3DPolyline?

[VVA]

Остальные (кроме Уровня) свойства есть у любых полилиний. Поэтому без разницы 3d или нет

Код:

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

(setq *PREC* 2) ;_точность округления
(setq *SCALEL* 1);_масштабный коэффициент
(vl-load-com)
(defun C:TEST1 ()
(if  
(and
  (setq en (car(entsel "\nУкажи полилинию")))
  (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE")
  )
(progn
;;Длина
(setq fld_Len (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Length \\f \"%lu2%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEL*)"]\">%"
                ) ;_ strcat
          ) ;_ setq
;;Слой
(setq fld_lay (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Layer>%"
                ) ;_ strcat
          ) ;_ setq

;;Тип линии
(setq fld_LT (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Linetype>%"
                ) ;_ strcat
          ) ;_ setq
(princ "\nПоле-длина: ")(princ fld_len)
(princ "\nПоле-слой: ")(princ fld_lay)
(princ "\nПоле-тип линии: ")(princ fld_lt)
)
(princ "\Объект не полилиния")
)
(princ)
  )

[DonJad]

to VVA
листинг выполнения для полилинии:

Command: test Укажи полилинию Поле-длина: %<\AcObjProp Object(%<\_ObjId 1962289528>%).Length \f "%lu2%pr2%ct8[1]">% Поле-уровень: %<\AcObjProp Object(%<\_ObjId 1962289528>%).Elevation \f "%lu2%pr2%ct8[1]">% Поле-слой: %<\AcObjProp Object(%<\_ObjId 1962289528>%).Layer>% Поле-тип линии: %<\AcObjProp Object(%<\_ObjId 1962289528>%).Linetype>% Command:

Acad2007... чет не работает. что первый что второй вариант.
Что вообще этот лисп делает?

[VVA]

DonJad, Сами команды опубликованы в #1,2,3 (различные варианты)
Лисп работает правильно. Он печатает тебе значения полей указанной полилинии. Если скопировать в буфер тест %< ... >% и вставить в рекакторе текста, то получись поле со ссылкой на соотв. свойство (длину, стлой или тип линии)

[acyxou]

Уважаемый VVA, как сделать так чтоб лисп в 2009-ом Автокаде работал?
Заранее спасибо за ответ.

[VVA]

acyxou, Нужно подправить или заменить ф-цию whatAcadVer

Код:

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

(defun whatAcadVer ( / Aver)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2011)
)
)

Писалась, когда еще не было 2009
PS. Обновил пост #3, исправить в #1 нужно просить Profan'a

[acyxou]

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

[VVA]

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

[acyxou]

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

Большое спасибо! То, что нужно!!!

[Павлов Андрей]

Здравствуйте . У меня вопрос : можно ли каким-то образом вставлять поля с объемом и массой для 3D solid ?

[Largo GT]

Отличный форум! Жаль, что раньше сюда не заходил, столько времени потерял
Ребята помогите с задачкой, я в LISPe новичок, а вам разминка.
Классная команда PTLB, а если ее немного переделать , суть задачки в следующем :
- есть замкнутая полилиния, нужно вставить в указанную точку рисунка или в существующий текст с заменой, текст с полем (FIELD), содержащий значение площади этого контура. При этом в установках можно выбирать шрифт вводимого нового текста, с выбором разделительного знака( . или ,) по принципу z-calc-text-value.

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

[LAmyk]

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

[VVA]

LAmyk,

Код:

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

(defun C:TEST ()
(vl-load-com)
(while (and
	 (princ "\nВыберите текст - источник: ")
	 (setq ss (ssget "_:S:E" '((0 . "TEXT"))))
	 (setq t1 (ssname ss 0))
	 (setq t1 (vlax-ename->vla-object t1))
	 (setq fld (vla-FieldCode t1))
	 (princ "\nВыберите текст - приемник: ")
	 (setq ss nil ss (ssget "_:S:E:L" '((0 . "TEXT"))))
	 (setq t2 (ssname ss 0))
	 )
  	 (vla-put-TextString (vlax-ename->vla-object t2) fld)
	 (entupd t2)
  )
  (princ)
  )

[LAmyk]

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

[Largo GT]

>LAmyk
попробуй здесь http://www.kitox.com/kitoxtools/helptools_ru.php
команда: Меняет текст по эталону, скачать можно бесплатно здесь http://www.kitox.com/kitoxtools_ru.php

[VVA]

Тогда так

Код:

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

(defun C:TEST ()
(vl-load-com)
(while (and
	 (princ "\nВыберите текст - источник: ")
	 (setq ss (ssget "_:S:E" '((0 . "*TEXT"))))
	 (setq t1 (ssname ss 0))
	 (setq t1 (vlax-ename->vla-object t1))
	 (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid t1)
                  ) ;_ vl-princ-to-string
                ">%).TextString>%"
                ) ;_ strcat
          ) ;_ setq
	 ;;(setq fld (vla-FieldCode t1))
	 (princ "\nВыберите текст - приемник: ")
	 (setq ss nil ss (ssget "_:S:E:L" '((0 . "*TEXT"))))
	 (setq t2 (ssname ss 0))
	 )
  	 (vla-put-TextString (vlax-ename->vla-object t2) fld)
         (command "_draworder" (vlax-vla-object->ename t1) "" "_U"  "" t2 "")
	 (entupd t2)
         
  )
  (princ)
  )

[zenon]

Можно я свои 5 копеек вставлю.
А может не мучится и предаствить пользователю самому выбирать что вставить из свойств объекта???

[LAmyk]

Сообщение от VVA Тогда так Код: [Выделить все] (defun C:TEST ()

спасибо, все работает.
Только вот с мтекстом не дружит(((

[VVA]

Сообщение от LAmyk Только вот с мтекстом не дружит(((

Добавил обработку MTEXT'a. Изменил #24. Изменения выделил красным

[LAmyk]

Сообщение от VVA Добавил обработку MTEXT'a. Изменил #24. Изменения выделил красным

после первого прохода от источника к риемнику
начинает подглючивать:


Команда: test
Выберите текст - источник:
Выберите объекты:
Выберите текст - приемник:
Выберите объекты:
_draworder
Выберите объекты: найдено: 1
Выберите объекты: _U
Выберите объекты:
Команда: <имя объекта: 7D837550>
Команда: TEST Неизвестная команда "TEST". Для вызова справки нажмите F1.
Команда:
Выберите текст - источник:
Выберите объекты:
Выберите текст - приемник:
Выберите объекты:
_draworder
Выберите объекты: найдено: 1
Выберите объекты: _U
Выберите объекты:
Команда: <имя объекта: 7D837540>
Команда: ; ошибка: Функция отменена

[VVA]

Исправил #24

[zenon]

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

[VVA]

zenon, У разных объектов разные свойства, не все свойства отображаются полями.

[zenon]

Сообщение от VVA zenon, У разных объектов разные свойства, не все свойства отображаются полями.

мысль такая, через поле "Object" указываешь объект, и выбираешь. Нужно избавиться от промежуточных операция.

[Largo GT]

Сообщение от VVA Вариант команды PAREATLB вставляет в таблицу тест с длиной примитива или площадью Код: [Выделить все] ; Команда: PTLB ; Эта команда позволяет вставить в указанную точку рисунка или указанную ячейку таблицы ; текст с полем (FIELD), содержащее значение площади или длины построенного или выбранного контура. ; Точность округления и масштабный коэффициент настраиваются через опцию Установки ; Так как это поле связано с конкретным объектом, то при изменении ; объекта поле пересчитывается (необходимо обновление поля) ; Код можно сохранить в файле ptlb.lsp ; Возможный макрос для кнопки или пункта меню: ; ^C^C(if (not C:PTLB) (load "ptlb"));PTLB; ;; Вариант макроса для задания м2 ;; ^C^C(if (not C:PTLB) (load "ptlb"));PTLB;_L;_S;1;0.001;2;5;;м2; ;;Где ;; _L - считать длинну (_A - площадь) ;; _S - установки ;; 1 - линейный масштабный коэффициент ;; 0.001 — площадной масштабный коэффициент ;; 2 — точность округления ;; 5 — высота текста ;; префикса нет ;; м2 - суффикс (defun C:PTLB ( / en cmdname fld txt fc tblset tblobj row col pt whatAcadVer tstyle what) ;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009 (defun whatAcadVer ( / Aver) (setq Aver (atof (substr (getvar "ACADVER") 1 4))) (cond ((= Aver 17.2) 2009) ((= 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 *SCALEL* (setq *SCALEL* 1)) (or *SCALEA* (setq *SCALEA* 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*)) (and (or ;_ > Проверяем версию (> (whatAcadVer) 2005) (alert "\nНужен Автокад версии 2006 и выше") ) ;_ < Проверяем версию (or (initget "Length Area Длина Площадь _Length Area Length Area") t) (if (null (setq what (getkword "\nЧто будем считать [Длина/Площадь] <Длина> :"))) (setq what "Length") t) (princ "\nТекущий масштаб: линейный = ")(princ *SCALEL*)(princ " площадной = ")(princ *SCALEA*) (princ " Текущая точность округления = ")(princ *PREC*) (princ " Высота текста = ")(princ *TEXTSIZE*) (princ " Префикс= ")(princ *PREF*)(princ " Суффикс= ")(princ *SUFF*) (or (initget "Polyline Setting sElect Полилиния Установки Выбор _Polyline Setting sElect Polyline Setting sElect") t ) (or ;_ > Запрашиваем что рисовать + опции (while (= (setq cmdname (getkword (strcat (if (= what "Area") "\n<Площадь> " "\n<Длина> ") "Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: "))) "Setting") (princ "\nНовый линейный масштабный коэффициент <")(princ *SCALEL*)(princ "> : ") (initget 6) (if (setq en (getdist))(setq *SCALEL* en)) (princ "\nНовый площадной масштабный коэффициент <")(princ *SCALEA*)(princ "> : ") (initget 6) (if (setq en (getdist))(setq *SCALEA* 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" (if (= what "Area") '((0 . "*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE")) '((0 . "LINE,*POLYLINE,ARC,CIRCLE"))) )) (setq en (ssname tblset 0)) ) ) (t nil) ) ;_ Формируем поле (cond ((= what "Area") (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 *SCALEA*)"]\">%" ) ;_ strcat ) ;_ setq ) ((and (= what "Length") (= (cdr(assoc 0 (entget en))) "CIRCLE") ) (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string (vla-get-objectid (vlax-ename->vla-object en)) ) ;_ vl-princ-to-string ">%).Circumference \\f \"%lu2%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEL*)"]\">%" ) ;_ strcat ) ;_ setq ) ((and (= what "Length") (= (cdr(assoc 0 (entget en))) "ARC") ) (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string (vla-get-objectid (vlax-ename->vla-object en)) ) ;_ vl-princ-to-string ">%).ArcLength \\f \"%lu2%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEL*)"]\">%" ) ;_ strcat ) ;_ setq ) ((and (= what "Length") (vlax-property-available-p (vlax-ename->vla-object en) "Length") ) (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string (vla-get-objectid (vlax-ename->vla-object en)) ) ;_ vl-princ-to-string ">%).Length \\f \"%lu2%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALEL*)"]\">%" ) ;_ strcat ) ;_ setq ) (t (setq fld "Неизвестное свойство")) ) (setvar "cmdecho" 0) (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)) ;_ Копируем в буфер и обратно (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) )

Пользуюсь командой PTLB - очень нравится я втянулся и теперь возникла потребность в преобразовании текста с полем (FIELD), содержащее значение площади в обычный текст.
Может не совсем понятно выражаюсь, поясню:
На планах этажей считал площади помещений, с помощью команды КОНТУР обводил полилинией помещения и командой PTLB проставлял площади. Теперь планы нужно передавать заказчику и не только ему одному, я хотел почистить планы: удалил контуры помещений (так сказать чтоб врагу не досталось) да только тексты с полями (FIELD) превращаются в #### после РЕГЕНа, а взорвать их не получается
подскажите пожалуйста как добиться желаемого ???

[VVA]

Largo GT, Как все поля чертежа сразу преобразовать в текст?

[Positron]

Помогите плиз кто разбирается, а можно ли пероброзовать етот лисп под другую цель, есть необходимость штоб не обекты, тоисть не площадь щитывала, а размеры щитывала в таблицу и при етом в 1ну клетку кидало 3 поля по очереди, типа "125х290х500" ...

Тось напимер нарисовал 1 раз шкаф с размерами и зделал спецыфикацыю с полями ... а потом еси надо просто потянул шаф с размерами и в спецыфикации обновились размеры...

[CB]

>Positron
Полное издевательство над русским языком...

[zenon]

Сообщение от Positron Помогите плиз кто разбирается, а можно ли пероброзовать етот лисп под другую цель, есть необходимость штоб не обекты, тоисть не площадь щитывала, а размеры щитывала в таблицу и при етом в 1ну клетку кидало 3 поля по очереди, типа "125х290х500" ... Тось напимер нарисовал 1 раз шкаф с размерами и зделал спецыфикацыю с полями ... а потом еси надо просто потянул шаф с размерами и в спецыфикации обновились размеры...

все это можно 1 раз нарисовать а затем как шаблон использовать.

[Positron]

Извините за русский ...
Но вопрос не в том что можно сделать шаблон, суть в быстром методе создавания полей с привязками к размерам...
А у меня специфика работы в том што часто надо новые создавать вещи ...
а если б кто помог кто луче "шарит" в лиспах начать эту тему то существенно помог..
Заранее спасибо огромное доброму человеку!

[VVA]

Positron, Выложи пример шкафа и таблицы с полями (dwg файл).

[Positron]

Сообщение от VVA Positron, Выложи пример шкафа и таблицы с полями (dwg файл).

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

[VVA]

Positron,

Код:

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

(defun C:BOXTLB ( / cmdname fld txt tblset tblobj row col dimtxt
                 whatAcadVer tstyle what
                 ss dim1 dim2 dim3)
(defun whatAcadVer ( / Aver)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2011)
)
)
  (vl-load-com)
 (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
  (and
    (or ;_ > Проверяем версию
      (> (whatAcadVer) 2005)
      (alert "\nНужен Автокад версии 2006 и выше")
      ) ;_ < Проверяем версию
    (princ "\nВыберите 1-й размер")
    (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION"))))
    (setq dim1 (vlax-ename->vla-object(ssname ss 0)))
     (setq dimtxt (strcat (vl-princ-to-string(vla-get-measurement dim1)) " x"))
    (or (vla-Highlight dim1 :vlax-true) t)
    (princ "\nВыберите 2-й размер : ")(princ dimtxt)
    (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION"))))
    (setq dim2 (vlax-ename->vla-object(ssname ss 0)))
    (or (vla-Highlight dim2 :vlax-true) t)
    (setq dimtxt (strcat dimtxt (vl-princ-to-string(vla-get-measurement dim2)) " x"))
    (princ "\nВыберите 3-й размер : ")(princ dimtxt)
    (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION"))))
    (setq dim3 (vlax-ename->vla-object(ssname ss 0)))
    (or (vla-Highlight dim3 :vlax-true) t)
    (princ (setq dimtxt (strcat dimtxt " " (vl-princ-to-string(vla-get-measurement dim3)))))
  ;_ Формируем поле
  ;;;  %<\AcObjProp Object(%<\_ObjId 2130564848>%).Measurement \f "%lu2%pr0">%
    (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 dim1))
                ">%).Measurement \\f \"%lu2%pr0\">%"
                "x"
                "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 dim2))
                ">%).Measurement \\f \"%lu2%pr0\">%"
                "x"
               "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(Get-ObjectID-x86-x64 dim3))
               ">%).Measurement \\f \"%lu2%pr0\">%"
                ) ;_ strcat
          ) ;_ setq
  (or (vla-Highlight dim1 :vlax-false)
      (vla-Highlight dim2 :vlax-false)
      (vla-Highlight dim3 :vlax-false)
   t)  
  (setvar "cmdecho" 0)
  (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))
  ;_ Копируем в буфер и обратно
  (vl-cmdf "_updatefield" txt "")
  (princ "\n Укажите точку вставки текста или ячейку таблицы(")(princ dimtxt)(princ ") :")
  (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)
  )
;;--------------------------------------------------------
;; Функция получает строковое представление 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)
     )
  )
)

[Positron]

Сообщение от VVA Positron, Код: [Выделить все] (defun C:DIMTLB ( / cmdname fld txt tblset tblobj row col dimtxt whatAcadVer tstyle what ss dim1 dim2 dim3) (defun whatAcadVer ( / Aver) ;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009 (setq Aver (atof (substr (getvar "ACADVER") 1 4))) (cond ((= Aver 18.0) 2010) ((= Aver 17.2) 2009) ((= 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 *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE"))) (and (or ;_ > Проверяем версию (> (whatAcadVer) 2005) (alert "\nНужен Автокад версии 2006 и выше") ) ;_ < Проверяем версию (princ "\nВыберите 1-й размер") (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION")))) (setq dim1 (vlax-ename->vla-object(ssname ss 0))) (setq dimtxt (strcat (vl-princ-to-string(vla-get-measurement dim1)) " x")) (or (vla-Highlight dim1 :vlax-true) t) (princ "\nВыберите 2-й размер : ")(princ dimtxt) (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION")))) (setq dim2 (vlax-ename->vla-object(ssname ss 0))) (or (vla-Highlight dim2 :vlax-true) t) (setq dimtxt (strcat dimtxt (vl-princ-to-string(vla-get-measurement dim2)) " x")) (princ "\nВыберите 3-й размер : ")(princ dimtxt) (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION")))) (setq dim3 (vlax-ename->vla-object(ssname ss 0))) (or (vla-Highlight dim3 :vlax-true) t) (princ (setq dimtxt (strcat dimtxt " " (vl-princ-to-string(vla-get-measurement dim3))))) ;_ Формируем поле ;;; %<\AcObjProp Object(%<\_ObjId 2130564848>%).Measurement \f "%lu2%pr0">% (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(vla-get-objectid dim1)) ">%).Measurement \\f \"%lu2%pr0\">%" "x" "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(vla-get-objectid dim2)) ">%).Measurement \\f \"%lu2%pr0\">%" "x" "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(vla-get-objectid dim3)) ">%).Measurement \\f \"%lu2%pr0\">%" ) ;_ strcat ) ;_ setq (or (vla-Highlight dim1 :vlax-false) (vla-Highlight dim2 :vlax-false) (vla-Highlight dim3 :vlax-false) t) (setvar "cmdecho" 0) (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)) ;_ Копируем в буфер и обратно (vl-cmdf "_updatefield" txt "") (princ "\n Укажите точку вставки текста или ячейку таблицы(")(princ dimtxt)(princ ") :") (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) )

Всё работает даже лучше чем я себе представлял эту команду, истиный мастер
ОГРОМНОЕ СПАСИБО!!!

[I`ch]

вопрос таков, как совместить #2 и #3. точнее заставить код из третьего сообщения автоматически продолжать вставлять значения прощадей/длин в таблицу?..
цены бы не было примочке этой.. )
/или это только у меня не работает?

лично мне показалось не совсем логичным описание "перемещаться по столбцам/строкам" - с первого раза понять трудно. может лучше сделать "располагать в столбец/строку"?

[Archeo]

Вечер добрый. Извиняюсь, что поднимаю старую тему. Где-то я вроде бы видел ЛИСП, который тоже вставляет куда надо текст с полем, соответствующим площади замкнутого контура, но предварительно делает оффсет этого контура на 20 мм внутрь (типа отделка). Рылся в поиске, но безрезультатно. Может, у кого-то есть? В идеале, хотелось бы иметь два варианта ЛИСПа: один - без оффсета (для помещений с существующей отделкой), второй - с оффсетом (для помещений с проектируемой отделкой).
По первому варианту меня почти устраивает ЛИСП от VVA (2007-10-04 10:26:53) с командой PAREATLB, но есть некоторые пожелания:
1. Разделителем целой и дробной части хотелось бы видеть запятую, но без изменения системных настроек AutoCAD или Windows.
2. Хочется, чтобы текст вставлялся в слой, отличный от текущего, с возвратом к текущему.
3. Самое главное: ЛИСП выполняется только в пределах одного пространства? Можно ли сделать так: вошёл в видовой экран, выбрал или построил полилинию, затем вышел из видового экрана, указал ячейку таблицы, расположенной в пространстве листа, и так далее? А то у меня таблицы в листах, а планировка в модели.
Если кто-нибудь сможет помочь, буду благодарен.

[Profan]

Вот здесь есть моя программа:
http://www.caduser.ru/forum/index.ph...D=44&TID=19751
Только там площадь выводится на экран и записывается в файл.
Возможно, где-то есть аналогичные программы.

[Archeo]

Profan, спасибо, но мне всё-таки нужно записывать результаты в пределах текущего файла dwg...

[ilya_sp]

не знаю, можно ли писать запросы в ветку "готовые программы"...

а можно к Лиспу в #24 добавить такую штуку:

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

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

[VVA]

ilya_sp, Пробуй. Название придумай сам. У меня сегодня с этим тяжело

Код:

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

(defun C:TEST ()
(vl-load-com)
(setvar "EXPERT" 5) ;_Для Supermax - установить обязательно
(setvar "CMDECHO" 0)  
(while (and
         (if (tblsearch "VIEW" "ViewTmpSource")
           (progn
             (command "_.VIEW" "_R" "ViewTmpSource")
             (command)
             t)
           t
           )
     (princ "\nВыберите текст - источник: ")
     (setq ss (ssget "_:S:E" '((0 . "*TEXT"))))
     (setq t1 (ssname ss 0))
     (setq t1 (vlax-ename->vla-object t1))
     (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (vla-get-objectid t1)
                  ) ;_ vl-princ-to-string
                ">%).TextString>%"
                ) ;_ strcat
          ) ;_ setq
     ;;(setq fld (vla-FieldCode t1))
         (progn (command "_.VIEW" "_Save" "ViewTmpSource")(command) t)
         (if (tblsearch "VIEW" "ViewTmpDest")
           (progn
             (command "_.VIEW" "_R" "ViewTmpDest")
             (command)
             t)
           t
           )
     (princ "\nВыберите текст - приемник: ")
     (setq ss nil ss (ssget "_:S:E:L" '((0 . "*TEXT"))))
     (setq t2 (ssname ss 0))
     )
       (vla-put-TextString (vlax-ename->vla-object t2) fld)
         (progn (command "_.VIEW" "_Save" "ViewTmpDest")(command) t)
         (command "_draworder" (vlax-vla-object->ename t1) "" "_U"  "" t2 "")
     (entupd t2)
         
  )
  (setvar "CMDECHO" 1)
  (princ)
  )

[ilya_sp]

Отлично! то, что нужно спасибо огромное!!

[Archeo]

Всем привет. К своему сообщению №44. Точку на запятую я исправил сам; как ни странно, в самом тексте ЛИСП. Со вторым вопросом хуже, ЛИСП-то я всё-таки не знаю... Попробовал сделать макрос

Код:

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

^C^C_.-Layer;_New;AREA;_Color;2;AREA;_Plot;n;AREA;;PAREATLB;_.Change;_Last;;_Properties;_C;ByLayer;_LW;ByLayer;_LT;ByLayer;_Layer;AREA;;TEXTSIZE;2.5;

на кнопку, чтобы выполнялась команда PAREATLB (она у меня в автозагрузке) и текст с полем вставлялся на другой слой, но где-то допустил ошибку. Т. е. слой создаётся, команда выполняется, но изменение свойств не происходит. Да, и почему-то этот текст пишется стилем Standard, а не текущим... Может ли кто-нибудь мне помочь довести это до ума?

[VVA]

Сообщение от Archeo Т. е. слой создаётся, команда выполняется, но изменение свойств не происходит. Да, и почему-то этот текст пишется стилем Standard, а не текущим... Может ли кто-нибудь мне помочь довести это до ума?

Найди в тексте эти строчки

Код:

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

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

Для слоя Area замени ;(cons 8 layer) на
(cons 8 "AREA") Обязательно убери коментарий - символ ; вначале

[Archeo]

VVA, спасибо! Со слоем и текстовым стилем всё получилось. Возник другой вопрос. Поле формируется из однострочного текста, а он не подхватывает из текущего стиля ширину 0.8 и угол наклона 15. К тому же хотелось бы видеть на плане эту надпись подчёркнутой. Можно ли это осуществить, или сделать вместо однострочного многострочный текст?

[VVA]

Замени на это

Код:

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

(setq txt (entmakex
(list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 72 0) ;_ выравнивание влево
(cons 1 (strcat "%%u" fld))
(cons 7 (getvar "TEXTSTYLE")) ;_Текущий стиль
(cons 8 "AREA") ;_Текущий слой
(cons 10 '(0 0 0))
(cons 11 '(0 0 0))
(cons 51 (cdr(assoc 50 (entget(TBLOBJNAME "STYLE" (getvar "TEXTSTYLE"))))))
(cons 41 (cdr(assoc 41 (entget(TBLOBJNAME "STYLE" (getvar "TEXTSTYLE"))))))
(cons 40 *TEXTSIZE*) ;_Высота текста
) ;_ list
) ;_ entmakex
)

[Archeo]

Спасибо, почти всё работает. За исключением одного момента: когда прицеливаешься и выбираешь точку вставки, то текст с полем отображается подчёркнутым, а после вставки подчёркивание пропадает... Шо бы это значило? Сейчас у меня текст кода такой:

Код:

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

;  Команда: 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*
                "]%ds44%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 (strcat "%%u" fld))
        (cons 7 (getvar "TEXTSTYLE")) ;_Текущий стиль
        (cons 8 "AREA") ;_Текущий слой
        (cons 10 '(0 0 0))
        (cons 11 '(0 0 0))
        (cons 51 (cdr(assoc 50 (entget(TBLOBJNAME "STYLE" (getvar "TEXTSTYLE"))))))
        (cons 41 (cdr(assoc 41 (entget(TBLOBJNAME "STYLE" (getvar "TEXTSTYLE"))))))
        (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)
  )

А можно ли всё-таки как-то предусмотреть ещё вариант оффсета полилинии (построенной или выбранной) на 20 мм внутрь? Только вот как дать программе понять, что в этом случае будет нужна площадь внутренней полилинии? И по поводу работы ЛИСПа в двух пространствах - никак? Придётся экспликации делать в пространстве модели?

[Chapter]

Всем привет. Можно ли данный код приспособить так, чтобы он брал площадь объектов находящихся на одном слое и суммировал в одну ячейку, а когда я выбираю другой объект, который принадлежит другому слою, то он начинает в след ячейку суммировать площади этих объектов. В данном случае этот объект "Штриховка".
и чтобы можно было изначально забивать масштабы по x y. Вызвали команду задали масштабы (след вызывание должно быть подтверждение enter предыдущего значения или новое значение) потыкали в штриховку получили суммы штриховок с одинаковыми слоями в разных ячейках таблицы. Способом построчно например.

И можно например было бы сделать так чтобы нажимать на штриховки не по порядку по слойно, а например сначало нажали на слой1-в первую ячейку попала площадь, потом слой2-во вторую ячейку попала площадь, потом опять слой1-суммировала в первую ячейку с тем что там уже имеется. то есть тыкать в разнобой по штриховке и быть уверенным что по слойно все сложится правильно.

И чтобы при заданных масштабах результат выдавало в гектарах в ячейки

Вот все вроде что хочется.

[DimAS]/[K]

Присоединяюсь к этой просьбе:

Спасибо, почти всё работает. За исключением одного момента: когда прицеливаешься и выбираешь точку вставки, то текст с полем отображается подчёркнутым, а после вставки подчёркивание пропадает... Шо бы это значило?

очень нужно, чтобы площадь была подчеркнутой

Проблема временно решена этим лиспом
http://forum.dwg.ru/showpost.php?p=228481&postcount=14

[Do$]

Делов то
в конце кода замените это:

Код:

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

(vlax-put txt 'TextString fld)

на это:

Код:

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

(vlax-put txt 'TextString (strcat "%%u" fld))

Пы.Сы. А если надо, чтоб в таблицу вставляло подчеркнутым, заменить эту строчку:

Код:

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

(or (vla-SetText tblobj row col fld) t)

на вот такую:

Код:

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

(or (vla-SetText tblobj row col (strcat "{\\L" fld "}")) t)

[VVA]

Для правильного формирования ObjectID в 64 разрядных системах нужно воспользоваться ф-цией, опубликованной Александром Ривилисом в этой теме

Код:

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

;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: https://discussion.autodesk.com/forums/message.jspa?messageID=6172961
;;--------------------------------------------------------
(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)
     )
  )
)

Сообщение от DimAS/K очень нужно, чтобы площадь была подчеркнутой

Код:

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

;  Команда: 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;

;;http://forum.dwg.ru/showthread.php?t=14528&page=3
;;;;; FIELDDISPLAY
(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 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2011)
)
)
  (vl-load-com)
  (or *SCALE* (setq *SCALE* 1))
  (or *ULINE* (setq *ULINE* t)) ;_Подчеркивание
  (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)
      (princ "\nПодчеркивать текст [Да/Нет] <")(princ (if *ULINE* "Да" "Нет"))(princ "> : ")
      (initget  "Да Нет Yes No_ Yes No Yes No")
      (if (setq en (getkword))(setq *ULINE* (= en "Yes")))
      (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 "
             (Get-ObjectID-x86-x64 en)
                ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%ds44%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 (strcat (if *ULINE* "%%u" "") fld))
        (cons 7 (getvar "TEXTSTYLE")) ;_Текущий стиль
        (cons 8 "AREA") ;_Текущий слой
        (cons 10 '(0 0 0))
        (cons 11 '(0 0 0))
        (cons 51 (cdr(assoc 50 (entget(TBLOBJNAME "STYLE" (getvar "TEXTSTYLE"))))))
        (cons 41 (cdr(assoc 41 (entget(TBLOBJNAME "STYLE" (getvar "TEXTSTYLE"))))))
        (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 (strcat (if *ULINE* "{\\L" "") fld (if *ULINE* "}" ""))) 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 (strcat (if *ULINE* "%%u" "") fld))
      )
    )
  )
  (princ)
  )
;;--------------------------------------------------------
;; Функция получает строковое представление 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)
     )
  )
)

[DimAS]/[K]

спасибо вам ребята

[DonJad]

VVA - опередил!!! тоже была проблема с 64 битным акадом.

Пять минут назад нашел эту же функцию, и проапгрейдил ею скрипт.

[Redya]

VVA, использую ваш лисп AREATT #2, всё замечательно. Единственное: он вставляет значение в милиметрах квадратных,а надобно в метрах кв. Приходиться кликать на каждоую ячейку со значение, и менять в поле коэффициент пересчета на 0.000001, а это очень много занимает времени. Как быть? Одним махом я так и не смог поменять коэффициент пересчета во всех нужных полях.

[VVA]

Сообщение от Redya Как быть?

Внимательно смотреть в командную строчку

Команда: areatt Текущий масштаб = 1 Текущая точность округления = 2 Высота текста = 1.5 Префикс= Суффикс= Перемещаться [по стРокам/по сТолбцам/Установки] <по сТолбцам>: У Новый масштабный коэффициент <1> : 0.000001 Точность округления <2> : 3 Высота текста <1.5> : Префикс (пробел - очистить) <> : Суффикс (пробел - очистить) <> : Перемещаться [по стРокам/по сТолбцам/Установки] <по сТолбцам>: Укажите ячейку таблицы: Выберите примитив для вставки его площади в таблицу (ENTER — завершение): Выберите примитив для вставки его площади в таблицу (ENTER — завершение):

Чтобы задать по умолчанию метры квадратные найди в тексте строчку

Код:

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

  (or *SCALE* (setq *SCALE* 1))

Замени на

Код:

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

  (or *SCALE* (setq *SCALE* 0.000001))

[Redya]

Offtop: VVA, я идиот, спасибо!

[Archeo]

VVA, спасибо! Всё работает, просто супер!
Вот только жаль, оффсета нету Ну и ладно, значит, не судьба. Главное - работает.

[Павлов Андрей]

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

[VVA]

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

Можно

Код:

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

;  Команда: MAREATT (Multiple AREA To Table)
;  posted http://dwg.ru/f/showthread.php?t=14528
;  Эта команда позволяет вставлять начиная с указанной ячейки таблицы
;  текст с полем (FIELD), содержащее значение площади выбранного контура.
;  В зависимости от выбора, навигация по таблице идет по строкам или столбцам.
;  Если стороки или столбцы заканчиваются, то они автоматически добавляются.
;  Форматирование ячейки берется как у первой указанной.
;  Точность округления и масштабный коэффициент настраиваются через опцию Установки
;  Так как это поле связано с конкретным объектом, то при изменении
;  объекта поле пересчитывается (необходимо обновление поля)
;  Код можно сохранить в файле mareatt.lsp
;  Возможный макрос для кнопки или пункта меню:
;  ^C^C(if (not C:MAREATT)(load "MAREATT"));MAREATT;

(defun C:MAREATT ( / en obj tblobj row col lst pt rows cols what fld ss)
  (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*)
  (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)
               (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))
    (princ "\nВыберите примитивы для вставки их площади в таблицу (ENTER — завершение): ")
    (setq ss (ssget))
    (while (and ss (> (sslength ss) 0) (setq en (ssname ss 0)))
      (cond
       ((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*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
                ) ;_ strcat
          )
        (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)))
        
       )
       (t(princ "\nДля этого примитива невозможно получить свойство Area!"))
      )
     (ssdel (ssname ss 0) ss)
    )
   )
   (t
     (princ "\nТаблиц не найдено!")
   )
  )
  (princ)
)

;;--------------------------------------------------------
;; Функция получает строковое представление 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)
     )
  )
)

[Павлов Андрей]

VVA .
Спасибо огромное !!!!!
Только вопрос : сортирует по времени отрисовки ?

[VVA]

Сообщение от Павлов Андрей Только вопрос : сортирует по времени отрисовки ?

[Павлов Андрей]

Здравствуйте .

Сообщение от VVA сортирует по времени отрисовки ?

Т.е. я хотел сказать по времени создания примитива ?

[Shaft]

Здравствуйте!
А возможно добавить следующее:

Иногда необходимо занести в ячейку таблицы сумму 2-х и более площадей. Не прерывая при этом дальнейшее выполнение программы.

пример:
-Запустил areatt и начал поочередно указывать интересующие меня объекты.

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

-Нажимаю (НАПРИМЕР) букву S (summa) программа переходит в режим суммирования. Нажимаю ENTER и результат вставляется в ячейку.

Зы. Так же добавить возможность вычитания по аналогии.

ЗЗы. Спасибо большое за вашу программу. Позволяет, ощутимо, снизить кол-во рутинной работы!

[VVA]

Shaft, Обновил #2

[Shaft]

Уважаемы VVA, Вы ГЕНИЙ! Безмерно Вам благодарен за помощь, которую Вы оказываете!!!
Это то, чего мне так не хватало! Теперь хватает!

[skkkk]

1. У меня в таблице, состоящей из всего одной ячейки, поле, ссылающееся на длину некоей линии. Если я копирую ячейку и линию вместе, то поле новой ячейки - что логично - ссылается на первую линию, а не на новую. Можно ли каким-то образом (блок, группа или еще что-то) эту пару объектов размножать так, чтобы каждая новая ячейка ссылалась на "свою" линию?
2. Аналогично, в такой вот ячейке стоит поле - ссылка на ширину этой же ячейки. Если копирую ее, поле новой ссылается на ширину старой. Поправимо?
Была мысль делать это блоком, затем вставлять блок и сразу взрывать его. Так не выходит. Тупик?

[Лиспер]

skkkk, вопрос: а если вместе с таблицей копируется несколько отрезков? Как программно определить, к какой копии должно относиться поле?

[Pavel23]

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

[VVA]

Сообщение от Pavel23 Коллеги, а никто не думал о том, что иногда нужно вставить поле в атрибут блока?

Посмотри здесь Area Field to Attribute

Program Description This program allows a user to populate a selected attribute with a Field referencing the area, or sum of areas, of one or more objects. The user is prompted to make a selection of objects for which to retrieve the area, if more than one object is selected the cumulative area for all objects will be displayed in the resultant Field. Following object selection, the user is prompted to select an attribute to house the Field string. The Field will display the sum of the areas of the selected objects, formatted in the current units and precision of the drawing.

[Pavel23]

Огромное спасибо VVA! Протестил лисп, работает пока нормально, без траблов. Правда изначально программа вставляла поле с площадью, немного докрутил, теперь вставляет то, что надо, поле длины. Это большое подспорье, извлекаю кабельный журнал из блоков в которых прописывается кабло, поле длины раньше вставлял ручками, ну теперь ваще, прям цельный САПР...

[Горян]

Доброго времени суток! Полезные программы! Спасибо! VVA один вопрос в #2 при выборе суммирования/вычитания не понимает масштабный коэффициент, выводит в мм2, в силу своей LISP-неграмотности сам исправить вряд ли смогу... Если не затруднит, поправьте пожалуйста... Очень уж пригодилась программа, а циферки лишние глаз корябают.
Область применения, если интересно: раскрой листового материала, много разноразмерных деталей сложной конфигурации, а отчеты формировать ручками приходится, правда не мне, а сотрудникам, но все равно мартышкин труд. Заранее благодарен.

[skkkk]

Сообщение от Лиспер skkkk, вопрос: а если вместе с таблицей копируется несколько отрезков? Как программно определить, к какой копии должно относиться поле?

Лиспер, условие моей задачи подразумевает одну линию, две мне попросту ни к чему
Я таки решил свою задачку с #73, обнаружив интересную закономерность (особенность) AutoCADa: Если блок вставить, а затем расчленить, то поле слетает, а если его вставить сразу с опцией Расчленить, то выходит, что можно

Сообщение от skkkk эту пару объектов размножать так, чтобы каждая новая ячейка ссылалась на "свою" линию

Опция Расчленить вызывается установкой соответствующей галочки в окне Вставка блока (интерактивный режим, команда _insert), либо в прозрачном режиме (команда _-insert) на запрос опции имени блока вставкой звездочки (*) перед именем. Только остался вопрос к программистам: в лиспе, в конструкции

Код:

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

(command "_-insert" "*name"............)

звездочка не действует. Как быть?

[VVA]

skkkk, Только что проверил, действует.
Создай блок с именем "BLK". Код ниже вставит его расчлененным в точку 100,100

Код:

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

(command "_-insert" "*Blk" "100,100" 1 1 0)

>Pavel23 Проверю, но позже. Сейчас катастрофически не хватает времени

[skkkk]

Offtop: VVA, виноват, каюсь... Сразу не подумал, а дело вот в чем: блок был создан без галочки Разрешить расчленение, поэтому и не работало. Как же тогда, создавая блок программно, быть уверенным, что он расчленится?

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

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

[skkkk]

Offtop: Тут, видимо, речь не о командном методе, который, пожалуй, "полупрограммный" Знаю, надо осваивать visual... Вот праздники впереди...Придется вместо заняться

[Pavel23]

Коллеги, я не в теме, но подозреваю, что необходимо вставить в чертеж блок расчлененным. Если дело только в этом, то я решаю это так:
^C^C_-insert;BLK;\;;;_explode;_last;
Почему делаю так, внутри BLK, в моем случае, находится динамический блок с кучей атрибутов, преследую две цели, после расчленения блок у меня уже находится в определенном слое, который не нужно создавать, хотя вставляете в любой слой, и при вставке нет никакого диалога связанного со значениями атрибутов. Я конечно не профи, но думаю на лиспе будет так же:
(command "_-insert" "BLK" "\\" "" "" "")
(command "_explode" "_last")

[skkkk]

Pavel23, с учетом #73 и #79 этот вариант не подходит, а виной тому - поля (fields) в ячейках таблицы, о чем повествует название темы

Добавлено:
на лиспе вместо "\\" используется pause pause:

Код:

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

(command "_-insert" "BLK" pause pause "" "")

[a_leo]

Прошу прощения за некомпетентность, но есть два вопроса:
1. можно ли в ячейку таблицы автоматом вставить текстовое значение ширины этой ячейки (форум просмотрел, похожее не нашел)
либо использовать ширину ячейки как параметр в формуле в этой либо другой ячейке
2. чем могут быть вызваны кракозябры вместо русских букв в запросах опций в автокаде в команде PTLB1.lsp (сама команда работает корректно). Пробовал менять кодировку на WIN1251, KOI8-R, UTF-8 - текстовый редактор отображает нормально, автокад - нет

[VVA]

Сообщение от a_leo 2. чем могут быть вызваны кракозябры вместо русских букв в запросах опций в автокаде в команде PTLB1.lsp

Попробуй скопировать еще раз, только убедись, что в момент копирования активна русская расладка клавиатуры

[Kraggash]

VVA, спасибо большое за чудесную программку (ну и товарищам Громову с Ривилисом тоже спасибо конечно). Порадую архитекторов.
Тока у меня один вопрос. Как бы сделать так, чтобы разделителем в получаемых полях стала запятая. Заранее извиняюсь если тема уже поднималась, а я не заметил.

[VVA]

Сообщение от Kraggash Как бы сделать так, чтобы разделителем в получаемых полях стала запятая

В любом редакторе в поиске и замене (Ctrl+H)
Найти: %ct8
Наменить на: %ds44%ct8

[a_leo]

Уважаемый VVA, премного благодарен за оперативный ответ

Попробуй скопировать еще раз, только убедись, что в момент копирования активна русская расладка клавиатуры

1. пробовал - для программы PTLB все замечательно работает
для программы PTLB1 (с caduser.ru, там где не поле, а текст) все равно кракозябры
2. а если имеется большое количество полилиний - можно ли организовать перебор т.е. после первой полилинии программа не завершает работу, а спрашивает вторую полилинию и т.д.

[Shaft]

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

[VVA]

Shaft, Она работает с объектами, у которых есть свойство "площадь" (Area). В том числе и со штриховками. Допускаю, что возможен вариант, когда штриховка не имеет свойста Area.

[Shaft]

Блин VVA, ну вы волшебник!!!
А я прочитав описание, (в котором говорилось только про контур) даже и не пытался выбирать другие объекты!!! Кроме контура построенного полилинией.

[VVA]

Shaft, Не всегда верь написанному Используй научный метод - метод тыка

[Shaft]

Сообщение от VVA Shaft, Не всегда верь написанному Используй научный метод - метод тыка

Буду иметь это ввиду!

Блин в автокад (2006 и 2008) при попытки запустить вашу программу... автокад выдает следующее:

Код:

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

 Текущий масштаб = 1 Текущая точность округления = 2 Высота текста = 2.5 
Префикс=  Суффикс= ; ошибка: неверный тип аргумента: lselsetp nil

Может вы знаете в чем может быть проблема?

upd: и в 2011 такая же ошибка вылазиет. А вчера всё работало прекрасно.
Причем все вышеуказанные версии автокада находяться на разных компьютерах.
Ps. Может это восстание машин/или автокадов?


upd-2: [s]Я нашел ошибку! Оказывается надо создать таблицу до того как запускаешь комманду!
Просто раньше я как-то незапускал её в чертежах, где небыло таблиц. Поэтому и незнал что наличие последней является объязательным

[Shaft]

Ребята, подскажите, а можно вместо полощади заносить в таблицу длину объектов?
Зы. Поиском удалось найти только программки суммирующие длины. Но это совсем не то.

[VVA]

Shaft, Вернись в начало темы и почитай пост #3

[Shaft]

Благодарю Вас уважаемый VVA, ведь я помнил что видел что-то подобное, а найти поиском несмог.
А оказалось что было всё у меня под носом.

[DimAS]/[K]

а можно ли сделать так чтобы лисп считал и выводил поле с площадью множества полилиний. такого вида:

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

[VVA]

Вариант с суммирование (вычитанием) площадей из #2 не подойдет?

[DimAS]/[K]

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

[VVA]

Сообщение от DimAS /[K;736435]подойдет, только нужно чтобы обязательно работал с атрибутами (вставлялся в них).

Посмотри это Area Field to Attribute

[Агент СмиТ]

Уважаемый VVA!
Пользую ваш лисп MAREATT - очень полезная вещь для землеустроителя, спасибо Вам! Однако когда решил воспользоваться PTLB для вставки площади замкнутой полилинии в пространство модели, столкнулся со следующим отказом в работе программы:

Команда: (if (not C:PTLB) (load "ptlb")) nil Команда: PTLB Что будем считать [Длина/Площадь] <Длина> :_A Текущий масштаб: линейный = 1.0 площадной = 0.0001 Текущая точность округления = 4 Высота текста = 5.0 Префикс= Суффикс= га <Площадь> Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: _S Новый линейный масштабный коэффициент <1.0> : 1 Новый площадной масштабный коэффициент <0.0001> : 0.0001 Точность округления <4> : 4 Высота текста <5.0> : 5 Префикс (пробел - очистить) <> : Суффикс (пробел - очистить) <га> : га <Площадь> Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: В Выберите полилинию, круг, сплайн, эллипс или дугу Выберите объекты: Найдено полей: 1. Обновлено полей: 1. Укажите точку вставки текста или ячейку таблицы:; ошибка: Ошибка Automation. На блокированном слое

После выбора объекта рядом с перекрестьем курсора появляется значение площади, но при нажатии ЛКМ, вместо цифр в поле появляется значение вида "######", а при попытке отредактировать поле появляется сообщение

Объект, на который ссылается поле, некорректен

Работаю в 2011 Акаде, попробовал добавить в код программы строку :

(cond ((= Aver 18.1) 2011) ((= Aver 18.0) 2010) ((= Aver 17.2) 2009) ((= Aver 17.1) 2008) ((= Aver 17.0) 2007)

но видимых результатов это не принесло. Подскажите пожалуйста, в чём загвоздка?

[VVA]

Агент СмиТ, Для начала давай так:
1. Из поста #3 копируешь последнюю версию
2. Пробуешь. Если есть ошибка, то выкладываешь тестовый файл и сообщаешь: версию Автокада с указанием разрядности, версию операционной системы с указанием разрядности, наличие/отсутсвие сервис паков для Автокада

[Агент СмиТ]

VVA, Скачал лисп из поста #3, для начала испробовал во вновь созданном файле и... всё сразу же заработало! Однако в рабочем файле отказ не ушел. Через два часа , методом последовательных итераций выяснил, что всё дело было в наличии таблицы на заблокированном слое, при разблокировании которой, лисп позволяет вставлять поле и в произвольную точку пространства модели, пространство листа не тестировал, но думаю что и там возможны подобные нюансы.
Посмотрите пожалуйста, можно ли устранить данный баг хотя бы в пространстве модели! Файл чертежа прикладываю.

[VVA]

Агент СмиТ, Обновил #3 побуй

[Агент СмиТ]

VVA
Обновил лисп в акаде, запустил из командной строки, вот листинг:

Команда: ptlb Что будем считать [Длина/Площадь] <Длина> :П Текущий масштаб: линейный = 1.0 площадной = 0.001 Текущая точность округления = 2 Высота текста = 5.0 Префикс= Суффикс= м2 <Площадь> Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: В неверный тип аргумента: VLA-OBJECT nil

Программа не даёт выбрать объект.

[VVA]

Скопируй еще раз. Должно писать это

Команда PTLB. Версия от 19.04.2011 http://forum.dwg.ru/showpost.php?p=183237&postcount=3 Команда: Команда: ptlb Что будем считать [Длина/Площадь] <Длина> :п Текущий масштаб: линейный = 1 площадной = 1 Текущая точность округления = 2 Высота текста = 1.5 Префикс= Суффикс= <Площадь> Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: в Выберите полилинию, круг, сплайн, эллипс или дугу Выберите объекты: Найдено полей: 1. Обновлено полей: 1. Укажите точку вставки текста или ячейку таблицы:

[Агент СмиТ]

Команда: properties Команда: Команда: Команда: _appload ptlb.lsp успешно загружено. Команда: Команда PTLB. Версия от 19.04.2011 http://forum.dwg.ru/showpost.php?p=183237&postcount=3 Команда: Команда: PTLB Что будем считать [Длина/Площадь] <Длина> :П Текущий масштаб: линейный = 1 площадной = 1 Текущая точность округления = 2 Высота текста = 2.5 Префикс= Суффикс= <Площадь> Выберите или нарисуйте [Полилиния/Установки/Выбор] <Выбор>: В неверный тип аргумента: VLA-OBJECT nil Команда: Команда: *Прервано*

Та же ошибка.

[VVA]

Исправил #3 Пробуй снова

[Агент СмиТ]

Спасибо, VVA! Всё отлично работает! Приступаю к труду на благо общества

[APavl]

Здравствуйте .
Подскажите , пожалуйста : можно ли заставить работать PTLB с таблицей ATABLE с сайта http://alxd.it-dept.ru/index.php может кто-то пробовал уже ?
Спасибо заранее .

[lovial]

Как-то перерыл множество лиспов и нашел нужный - по клику в пространстве, ограниченном отрезками, выводит текст с площадью (т.е. сам создает контур). Однако куда-то его затаскал и найти в куче всего не получилось. Ткните, если можно, носом в пост/ссылку...

[dew]

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

Код:

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

;  Команда: 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;

;;http://forum.dwg.ru/showthread.php?t=14528&page=3
;;;;; FIELDDISPLAY
(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 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2011)
)
)
  (vl-load-com)
  (or *SCALE* (setq *SCALE* 1))
  (or *ULINE* (setq *ULINE* t)) ;_Подчеркивание
  (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)
      (princ "\nПодчеркивать текст [Да/Нет] <")(princ (if *ULINE* "Да" "Нет"))(princ "> : ")
      (initget  "Да Нет Yes No_ Yes No Yes No")
      (if (setq en (getkword))(setq *ULINE* (= en "Yes")))
      (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 "
             (Get-ObjectID-x86-x64 en)
                ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
                "]%ds44%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 (strcat (if *ULINE* "%%u" "") fld))
        (cons 7 (getvar "TEXTSTYLE")) ;_Текущий стиль
        (cons 8 "AREA") ;_Текущий слой
        (cons 10 '(0 0 0))
        (cons 11 '(0 0 0))
        (cons 51 (cdr(assoc 50 (entget(TBLOBJNAME "STYLE" (getvar "TEXTSTYLE"))))))
        (cons 41 (cdr(assoc 41 (entget(TBLOBJNAME "STYLE" (getvar "TEXTSTYLE"))))))
        (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 (strcat (if *ULINE* "{\\L" "") fld (if *ULINE* "}" ""))) 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 (strcat (if *ULINE* "%%u" "") fld))
      )
    )
  )
  (princ)
  )
;;--------------------------------------------------------
;; Функция получает строковое представление 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)
     )
  )
)

[APavl]

Здравствуйте . А можно сделать чтобы площади/длины выделенных примитивов выводились в файл Excel ?

[VVA]

APavl,
1. Можно создать связь таблицы Автокада с таблицей Excell
2. Как вывести в эксель длинны нескольких линий?

[Largo GT]

Сообщение от lovial Как-то перерыл множество лиспов и нашел нужный - по клику в пространстве, ограниченном отрезками, выводит текст с площадью (т.е. сам создает контур). Однако куда-то его затаскал и найти в куче всего не получилось. Ткните, если можно, носом в пост/ссылку...

Если еще интересует... такое есть или в "G_Tools" или
в "VetCAD++"

[APavl]

VVA, Спасибо за ссылку .
Я вставляю в ACAD 2008 связанную таблицу со спецификацией из Excel (просто там всё гарантированно считается , в таблице Acad нужно ещё проверять) . Слышал , что в более поздних версиях ACAD можно вставлять двустороннюю связь таблиц acad-excel , но у меня acad 2012 вылетает постоянно из-за нехватки памяти . Поэтому длины беру из acadа , считаю в excele , вставляю спецификацию обратно в acad . Хорошо бы ещё показывало количество , одинаковые длины складывало .... Но , наверное , многого хочу .

[shartal]

В команде PTLB точность настраивается для знаков после запятой. При вставке в таблицу длины арматуры в мм, требуется округление до 0 или 5 (1357 в 1360). возможно ли это реализовать?

[VVA]

shartal, Обновил #3 Добавилась новая настройка - округление. Тестируй.

[serdgius]

Почему то PAREATLB в 2010 не хочет работать в 2007 проверил работает. В чем может быть проблема?

[VVA]

serdgius, Дай ссылку на пост где брал. Исправлю. А вообще дело в функции whatAcadVer. Замени на эту

Код:

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

(defun whatAcadVer ( / Aver)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.2) 2012)  
((= Aver 18.1) 2011)  
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2013)
)
)

[serdgius]

Пост №1 исправленный который. Попытался вставить, без изменений, я в лиспе не силен. Буду премного, если поможете. Такой еще вопрос в Area Field to Attribute, как нибудъ можно менять маштабный коэффициент, или может есть еще подобный лисп.

[VVA]

В #3 есть дальнейшее развитие этой команды. Посмотри, может понравится. По поводу замены ничего сложного нет. В #1 изменить не могу, писал не я. Выложу вариант здесь

Код:

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

 
; Команда: 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)
;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.2) 2012)  
((= Aver 18.1) 2011)  
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2013)
)
)
(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)
)

[shartal]

При вставке в таблицу \ или / убивается и в ячейке оказывается только код символа U+E738.

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

попробуй использовать двойной слеш: "\\"

[Do$]

Я с таким сталкивался, когда использовал метод vla-get-textstring, он строки с символами юникода вот так вот коверкает. Мне пришлось отказаться от vla и заменить (vla-get-textstring obj) на конструкцию (cdr (assoc 1 (entget (vlax-vla-object->ename obj)))). Может здесь то же самое.

[shartal]

Два \\ только с ком строки можно использовать. Макрос на строке с \ останавливается.
Нашел способ прописать с \\\ прямо в формирование поля в код.

[Positron]

Сообщение от VVA Positron, Код: [Выделить все] (defun C:DIMTLB ( / cmdname fld txt tblset tblobj row col dimtxt whatAcadVer tstyle what ss dim1 dim2 dim3) (defun whatAcadVer ( / Aver) ;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009 (setq Aver (atof (substr (getvar "ACADVER") 1 4))) (cond ((= Aver 18.0) 2010) ((= Aver 17.2) 2009) ((= 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 *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE"))) (and (or ;_ > Проверяем версию (> (whatAcadVer) 2005) (alert "\nНужен Автокад версии 2006 и выше") ) ;_ < Проверяем версию (princ "\nВыберите 1-й размер") (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION")))) (setq dim1 (vlax-ename->vla-object(ssname ss 0))) (setq dimtxt (strcat (vl-princ-to-string(vla-get-measurement dim1)) " x")) (or (vla-Highlight dim1 :vlax-true) t) (princ "\nВыберите 2-й размер : ")(princ dimtxt) (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION")))) (setq dim2 (vlax-ename->vla-object(ssname ss 0))) (or (vla-Highlight dim2 :vlax-true) t) (setq dimtxt (strcat dimtxt (vl-princ-to-string(vla-get-measurement dim2)) " x")) (princ "\nВыберите 3-й размер : ")(princ dimtxt) (setq ss nil ss (ssget "_+.:E:S" '((0 . "DIMENSION")))) (setq dim3 (vlax-ename->vla-object(ssname ss 0))) (or (vla-Highlight dim3 :vlax-true) t) (princ (setq dimtxt (strcat dimtxt " " (vl-princ-to-string(vla-get-measurement dim3))))) ;_ Формируем поле ;;; %<\AcObjProp Object(%<\_ObjId 2130564848>%).Measurement \f "%lu2%pr0">% (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(vla-get-objectid dim1)) ">%).Measurement \\f \"%lu2%pr0\">%" "x" "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(vla-get-objectid dim2)) ">%).Measurement \\f \"%lu2%pr0\">%" "x" "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string(vla-get-objectid dim3)) ">%).Measurement \\f \"%lu2%pr0\">%" ) ;_ strcat ) ;_ setq (or (vla-Highlight dim1 :vlax-false) (vla-Highlight dim2 :vlax-false) (vla-Highlight dim3 :vlax-false) t) (setvar "cmdecho" 0) (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)) ;_ Копируем в буфер и обратно (vl-cmdf "_updatefield" txt "") (princ "\n Укажите точку вставки текста или ячейку таблицы(")(princ dimtxt)(princ ") :") (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) )

Плиз, помогите в автокаде версии 2012 не пашет, чо дописать надо шоб работало? и сразу для 2013 еси не трудно..

--- Разабрался ((= Aver 18.0) 2010) ((= Aver 18.1) 2011) ((= Aver 18.2) 2012)
А 2013 будет 19.0 ????

[VVA]

Вместо

Код:

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

(cond
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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)
)

Впиши

Код:

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

(cond
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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 2011)
)

В коде проверяется Автокад версии 2006 и выше (появились формулы) или нет. На сегодняшний момент мало у кто уже работает в 2005 и ниже Автокаде. Так что проверку вообще можно убрать. Замени функцию

Код:

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

(defun whatAcadVer ( / Aver)
  ;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= 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)
)
)

на

Код:

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

(defun whatAcadVer ( / Aver)2011)

и забей забудь про проблему

[Positron]

Сообщение от VVA Вместо Код: [Выделить все] (cond ((= Aver 18.0) 2010) ((= Aver 17.2) 2009) ((= 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) ) Впиши Код: [Выделить все] (cond ((= Aver 18.0) 2010) ((= Aver 17.2) 2009) ((= 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 2011) ) В коде проверяется Автокад версии 2006 и выше (появились формулы) или нет. На сегодняшний момент мало у кто уже работает в 2005 и ниже Автокаде. Так что проверку вообще можно убрать. Замени функцию Код: [Выделить все] (defun whatAcadVer ( / Aver) ;;;Ф-ция возвращает версию Автокада ввиде 2004 2005 2006 2007 2008 2009 (setq Aver (atof (substr (getvar "ACADVER") 1 4))) (cond ((= Aver 18.0) 2010) ((= Aver 17.2) 2009) ((= 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) ) ) на Код: [Выделить все] (defun whatAcadVer ( / Aver)2011) и забей забудь про проблему

спасибо

[Nata1]

Уважаемый VVA, в посте #1 (2007-09-20 16:36:57) в коде лиспа PAREATAB написано

; Код можно сохранить в файле 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)

Я красным выделила, это опечатка? Надо так?

defun C:PAREATAB

[VVA]

Nata1,Спасибо за внимательность. Да в этом посте надо так. Исправить не могу, т.к. пост не мой. Скажу лишь, что после этой публикации команды менялись. Дальнейшее развити есть в посте #3, в том числе там есть ссылка и на обновленную PAREATLB

[Nata1]

Спасибо за лиспы, очень нужная вещь.
Попробовала лисп AREATT
Вариант с суммирование (вычитанием) площадей из поста #2
и заметила особенность. Вводишь масштабный коэффициент, например, 0.01, а он после применения "+" или "-" сбивается и в таблице записывается с коэффициентом 1.
Может, я не правильно команду использую? Делаю так:

Команда: AREATT Текущий масштаб = 0.01 Текущая точность округления = 2 Высота текста = 2.0 Префикс= Суффикс= Перемещаться [по стРокам/по сТолбцам/Установки] <по сТолбцам>: Укажите ячейку таблицы: Выберите примитив для вставки его площади в таблицу (+ сумма; - вычитание; ENTER — завершение): + ENTER СУММИРОВАНИЕ > Выберите примитив для вставки его площади в таблицу (ENTER — завершение): Выбираю объект ENTER СУММИРОВАНИЕ > Выберите примитив для вставки его площади в таблицу (ENTER — завершение): Выбираю объект ENTER Выберите примитив для вставки его площади в таблицу (+ сумма; - вычитание; ENTER — завершение):

В таблице выводится сумма выбранных объектов, но без указанного коэффициента, а после выбора суммирования или вычитания ввести коэффициент уже нельзя.
В других лиспах из этой темы нет возможности суммирования/вычитания полей.

[VVA]

Nata1, Я попробовал, у меня масштаб сохраняется. Посмотри содержимое поля, там должно быть что-то похожее на

%<\AcObjProp.16.2 Object(%<\_ObjId 2127578448>%).Area \f "%lu2%pr3%ct8[0.01]">%

[Nata1]

VVA, да, именно так и есть. На первом скрине "Окно1" поле, которое у меня получилось после вычитания полей. Мне пришлось вручную заменять точку на запятую, менять масштабный коэффициент, формат и точность. Тогда стало все, как надо. См. второй скрин "Окно2"
По идее, должно ведь все автоматически делаться. Может, какие-то настройки полей поменять надо?

[VVA]

Nata1,мне нужно содержимое поля в формуле. Тебе нужно дважды щелкнуть на цифре 91.90 из 1-го рисунка.И ничего не меняй в ручную, просто скопируй сюда содержимое поля. Еще меня настораживает фраза

Сообщение от Nata1 Мне пришлось вручную заменять точку на запятую

Какие у табя региональные настройки в Windows?

[Nata1]

VVA, спасибо! Вот, что в поле написано:
Это для обеих цифр, если выбрать в ячейке таблицы "Редактировать поле":

%<\AcExpr (%<\_FldPtr 364517392>%-%<\_FldPtr 364516128>%)>%

Это, если щелкнуть на 91.90

%<\AcObjProp.16.2 Object(%<\_ObjId 2129725528>%).Area \f "%lu2%pr2%ds44%ct8[0.01]">%

А это при щелчке на 0.25

%<\AcObjProp.16.2 Object(%<\_ObjId 2129727520>%).Area \f "%lu2%pr2%ds44%ct8[0.01]">%

И уже вижу, по отдельности коэффициент в полях стоит, а в суммарном поле его нет. И в отдельных цифрах запятая, а не точка, а в сумме получается точка.
Повторю, что введенный коэффициент не сохраняется и вместо точки ставится запятая только при применении сложения/вычитания. У меня начерчено в модели в масштабе 1:100 и поэтому у полей тоже делаю такой масштаб.

Какие у табя региональные настройки в Windows?

А где это смотреть? У меня вроде никогда не было проблем с точкой и запятой в автокаде.

[VVA]

Nata1, Мне не понятно откуда в поле берется (разделитель - запятая)

%<\AcObjProp.16.2 Object(%<\_ObjId 2129727520>%).Area \f "%lu2%pr2%ds44%ct8[0.01]">%

Я его в команде не формирую. Региональные настройки смотри в
Пуск -> Панель управления

[Nata1]

Настройки посмотрела. Точка стоит.

[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). Глюк не постоянный, в новом файле обычно все окей. Когда возникает, с чем связан, - не знаю.. Вроде связан с файлом, а не компом, - на других открываешь файл, - глюк остается.

[DEM]

Offtop:

Сообщение от AlexV глюк остается.

Меньше в чате сидеть надо.....

[Nata1]

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

VVA, КЛАСС и СУПЕР! Огромное СПАСИБО! Перейду с AREATT-а на ATTSS.

[VVA]

>Nata1 На здоровье
>AlexV, Глюк подтверждаю. Как побороть - не знаю. Правильнее, наверное, так

Сообщение от AlexV По непонятной причине перестают обновляться поля формулы в таблицах

[AlexV]

Сообщение от VVA >Nata1 На здоровье >AlexV, Глюк подтверждаю. Как побороть - не знаю. Правильнее, наверное, так

Ну, не обязательно кстати сказать формулы. Поля в ячейках со ссылкой к примеру на свойства чертежа, - тоже перестают обновляться. Причем совершенно непредсказуемо иногда файл "вылечивается", - но ненадолго. Предпологал, что це могло быть связано с использованием vba, - у меня таблицы спецификации и ВРС считаются автоматом, - может "objtabl.RegenerateTableSuppressed = True.... objtabl.RegenerateTableSuppressed = False" как-то "портят" таблицу. Но никакой прямой связи нет, после работы макроса все может быть окей, а через какое то время - бац, и перестали обновляться.. Запарило однако это дело, уж сколько раз замазывал в выдаваемых комплектах шифры, даты, фамилии и т.д., - из-за глюков этих с полями.

[Garand]

Изменил для себя код из поста #2, сделал извлечение не площади, а длины.
Не получилось сделать повтор запроса при невыборе объекта, если объект не указан, программа прекращает выполняться.
И нельзя ли сделать еще записывание также в ячейки содержимого мулитьвыноски, причем циклом, перед извлечением длины полилинии?
Т.е. первый клик -на мультивыноску - содержимое в ячейку, второй клик на полилинию - длину в соседнюю (или еще лучше, указанную заранее другую) ячейку, с перемещением также по строкам.

[Виталий Владимирович К]

Уважаемые форумчане! Не могли бы вы переделать код из#1, чтобы указывая на текст или мтекст в таблицу вставлялось поле со значением этого текста, и что бы можно было задавать шаг вставки через одну ячейку, две.... И т.д.
И еще подскажите код для автоматической нумерации, сначала программа спросила скакого номера начинать затем тыкаю куданибудь и появляется текст с номером

[Агент СмиТ]

Сообщение от Виталий Владимирович К И еще подскажите код для автоматической нумерации, сначала программа спросила скакого номера начинать затем тыкаю куданибудь и появляется текст с номером

Попробуй это

[VVA]

Сообщение от Виталий Владимирович К важаемые форумчане! Не могли бы вы переделать код из#1, чтобы указывая на текст или мтекст в таблицу вставлялось поле со значением этого текста,

Виталий Владимирович К, Посмотри варианты, начиная с #2

Сообщение от Виталий Владимирович К и что бы можно было задавать шаг вставки через одну ячейку, две.... И т.д

В том же #2 найди в коде

Код:

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

...(1+ col) ... (1+ row)...

и замени на нужное

[Виталий Владимирович К]

Попытался переделать lisp, но чего то не получается выдает ошибку. Может кто-нибудь исправит

Код:

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

 					;  Команда: TEST 
					;  posted http://dwg.ru/f/showthread.php?t=14528


(defun C:MAREATT (/ en obj tblobj row col lst pt rows cols what fld ss)
  (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*)
  (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)
	   )
	   (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))
     (princ
       "\nВыберите текст для вставки его значения в таблицу (ENTER — завершение): "
     )
     (setq ss (ssget))
     (while (and ss (> (sslength ss) 0) (setq en (ssname ss 0)))
       (cond
	 ((vlax-property-available-p (setq en (vlax-ename->vla-object en)) TextString)
	    (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa id) ">%).TextString>%"))
		(vl-princ-to-string (Get-ObjectID-x86-x64 en))
		   ""TextString""
			)
		 ;_ strcat
	  )
	  (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))
	  )

	 )
	 (t
	  (princ
	    "\nДля этого примитива невозможно получить значие TextString!"
	  )
	 )
       )
       (ssdel (ssname ss 0) ss)
     )
    )
    (t
     (princ "\nТаблиц не найдено!")
    )
  )
  (princ)
)

;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: https://discussion.autodesk.com/foru...sageID=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)
    )
  )
)

[gomer]

чо за бред?

[Виталий Владимирович К]

Сообщение от VVA В том же #2 найди в коде Код: [Выделить все] ...(1+ col) ... (1+ row)... и замени на нужное

Получилось поменять значение площади на содержимое текста, но ни как неполучается сделать так, чтобы значения в таблице записывались через одну ячейку. Может кто- нибудь подскажет?

[DEM]

Сообщение от Виталий Владимирович К через одну ячейку.

(setq col (1+ col)) (setq row (1+ row))

Тута правь...
Вас там еще не полностью затопило????

[Виталий Владимирович К]

Затопило сильно, неделю назад на вертолете летел на вахту подчти через всю область, если не река разлилась то просто озера на полях из- за дождей образовались, все лето дожди идут. Сейчас погода установилась, реки начались спадать. Спасибо за ответ. Где почитать про "col and row". В книге Полищука нету описания этих функций?

[DEM]

Дык ты просто по играй с значениями...
(setq col (ХХХХХ+ col))
(setq row (ХХХХХ+ row))

[Агент СмиТ]

Offtop:

Сообщение от Виталий Владимирович К Затопило сильно...

Приамурье, держитесь!!!

[Виталий Владимирович К]

(vla-GetRowHeight tblobj (1- row)) 2)- разобрался, цифра выделенная красным добавляет количество строк в таблице, если она закончилась.
(setq row (1+ row))- заполняет значениями каждую строку, меняю на 2-ошибка.Помогите.

[Лентяй]

Сообщение от Виталий Владимирович К (setq row (1+ row))- заполняет значениями каждую строку, меняю на 2-ошибка.Помогите.

А так:

Код:

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

 (setq col (+ 2 col) row (+ 2 row))

?

[Виталий Владимирович К]

Сообщение от Лентяй 1(setq col (+ 2 col) row (+ 2 row))

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

[DEM]

Сообщение от Виталий Владимирович К По строкам вставляет одно поле, по столбцам вставляет через одну ячейку но по диагонали, а надо по вертикали

НУ тебе же намекнули...

(if (= what "Col")(setq col (+ 2 col))(setq row (1+ row)))

Я долго разбирался потому как для меня давно уже не очевидно

(setq col (+ 2 col))

[Виталий Владимирович К]

Всем большое спасибо заработало

[DEM]

Виталий Владимирович К
С вас фото разлива Амура и затопления Владимировки

[Виталий Владимирович К]

Чего то не получается прикрепить фотографии.

[A.Hillys]

Сообщение от Виталий Владимирович К Получилось поменять значение площади на содержимое текста....

Каким образом? Код предоставите?

[A.Hillys]

Также получилось поменять значение площади на длину, и на содержимое текста. Не получилось - на содержимое атрибутов блока.
Подскажите, как это реализовать?

[peacemaker_kiss]

Что же получается lisp`ом нельзя померить площадь блока! А если скажем есть фасад, который внутри блока отрисован в определенном масштабе, имеет определенное имя и нужна его площадь в ячейки таблицы

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

Загоняем в блок точку и отрезок. Какая площадь будет у этого блока?
peacemaker_kiss, создай штриховку и бери ее площадь.

[peacemaker_kiss]

Так то да, но как заштриховать теперь блок, который имеет форму статуи свободы скажем

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

О, еще и трехмерку сюда же? peacemaker_kiss, определи сначала задачу, а потом уже и решения искать надо.

[peacemaker_kiss]

Все сработает конечно через штриховку

----- добавлено через ~3 мин. -----
теперь буду пробовать писать код, чтобы лисп искал блок штриховал его считал площадь штриховки, заносил в таблицу и удалял штриховку. От души спасибо, ибо начинающий кодописец, сидел ломал голову, что с блоком сделать, а решение элементарное

[peacemaker_kiss]

Не знаешь почему?

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

К кому обращение? И "почему" что?

[peacemaker_kiss]

Почему автокад не показывает площадь штриховки???

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

Так, файл нужен