Настройки поиска

Единственный (надеюсь, что пока) нормальный вариант. LISP.
Сделал 2 кнопки-макросы с настроенными параметрами.

; Команда: 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
13.05.15   
*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&postcou..")
(princ)

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