Показать сообщение отдельно
 
Непрочитано 21.03.2012, 13:54
#124
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,801
<phrase 1= Отправить сообщение для VVA с помощью Skype™


В #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)
)
__________________
Как использовать код на Лиспе читаем здесь
VVA на форуме  
 
Размещение рекламы