Vladimir Mich пишет:Спасибо, Fixo! То что нужно. Уверен многие проектировщики скажут вам ОГРОМНОЕ СПАСИБО за новую команду AutoCAD. Десять лет не мог понять, почему этого нет в AutoCAD-е.
Vladimir and Dmitry,
Попробуйте ещё измененную версию, добавил кое-что
К сожалению, я не спец, а просто хоббер, поэтому
не знаю какие тонкости могут быть в вашей работе
можно теперь добавлять слой и тестовый стиль,
добавлен обработчик ошибок и откат изменений
(см. пояснения в тексте кода, что надо измените сами)
Vladimir, замер между двумя точками кривой за мной,
будет попозже, после получения комментариев, чтобы не делать
лищней работы
;;--------------------------------- distan.lsp ------------------------------------;;
;; fixo () 2011 * all rights released (типа делай с ней что хошь)
;; редакция от 12 февр. 2012
(defun C:distan(/ *error* acsp adoc ang clay clr clt clw curh curst da degs dimz dist fd hgt
kw mtx osm par pick pline plpt sset style styles txtp)
;;;
(defun *error* (msg)
(vla-endundomark adoc)
(cond ((not msg))
((vl-position
msg
'("Function cancelled" "quit / exit abort" "console break")
)
)
((princ (strcat "\nDistan Command Error: " msg)))
)
(if clay (setvar "clayer" clay))
(if clr (setvar "cecolor" clr))
(if clt (setvar "celtype" clt))
(if clw(setvar "celweight"clw))
(if osm (setvar "osmode" osm))
(if dimz (setvar "dimzin" dimz))
(setvar "cmdecho" 1)
(princ)
)
;;;
(defun addlayer (adoc layername ltype lweight color / layer)
(if
(not
(vl-catch-all-error-p
(setq layer
(vl-catch-all-apply
'vla-add
(list (vla-get-layers adoc) layername)
)
)
)
)
(progn
(vl-catch-all-apply 'vla-put-linetype (list layer ltype));; если тип линии не загружен, используется continuous по умолчанию
(if (and (>= lweight -3 )(<= lweight 211));; значение в интервале -3...211 (согласно валидным значениям)
(vl-catch-all-apply 'vlax-put (list layer 'lineweight lweight)))
(if (and (>= color 0 )(< color 256));; значение в интервале 0...255, 256 для слоя не используется
(vl-catch-all-apply 'vlax-put (list layer 'color color))))
)
layer
)
;;;
(defun angtangent (pline pt)
;; by Charles Alan Butler aka CAB
(angle
'(0 0 0)
(trans
(vlax-curve-getFirstDeriv
pline
(vlax-curve-getParamAtPoint pline (trans pt 1 0))
)
0 1 T
)
)
)
;; Создание стиля текста, если он отсутствует в документе
;; пример:
;;;(add-textsyle adoc
;;; "ANNO-GIS-TEXT"; имя стиля текста
;;; "ISOCPEUR" ; имя шрифта без расширения (если его нет, тогда будет по умолчанию, скорей всего "ARIAL"
;;; nil ; если nil тогда нежирный, если Т тогда жирный
;;; nil ; если nil тогда обычный, если Т тогда курсив
;;; 0.0 ; высота текста
;;; 0.75; ширина букв
;;; )
(defun add-textsyle(adoc name font bold italic height width)
(setq styles(vla-get-textstyles adoc))
(if (not (tblsearch "style" name))
(progn
(vl-catch-all-apply 'vla-add (list styles name))
(vl-catch-all-apply
'(lambda ()
(vla-setfont
(setq style (vla-item
styles
name
)
)
font ; font name
(if bold
:vlax-true
:vlax-false
) ; non-bold (otherwise :vlax-true)
(if italic
:vlax-true
:vlax-false
) ; italic (otherwise :vlax-false)
0 ; symbol's flag
32 ; sum of flag values for ticks and characters
)
)
)
(vl-catch-all-apply 'vla-put-height (list style height))
(vl-catch-all-apply 'vla-put-width (list style width))
)
)
(princ)
)
;;; ------------------------------ Основная программа -----------------------------------;;
(setq adoc (vla-get-activedocument
(vlax-get-acad-object)
)
)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-endundomark adoc)
(vla-startundomark adoc)
;;;
(defun right-ang(ang /)
(if (< (/ pi 2) ang (* pi 1.5))
(setq ang (+ ang pi)))
ang
)
;;; ------------- Системные переменные > -----------;;
(setq clay (getvar "clayer"))
(if (not (tblsearch "layer" "ANNO-TEXT"));<-- измени имя слоя здесь ----------------
(addlayer adoc "ANNO-TEXT" "bylayer" -3 30));<-- измени имя слоя здесь ----------------
(setq layerobj (vla-item (vla-get-layers adoc) "ANNO-TEXT"));<-- измени имя слоя здесь ----------------
(vl-catch-all-apply 'vla-put-lock (list layerobj :vlax-false))
(vl-catch-all-apply 'vla-put-layeron (list layerobj :vlax-true))
(vl-catch-all-apply 'vla-put-freeze (list layerobj :vlax-false))
(setvar "clayer" "ANNO-TEXT");<-- измени имя слоя здесь ----------------
(setq clr (getvar "cecolor"))
(setvar "cecolor" "ByLayer")
(setq clt (getvar "celtype"))
(setvar "celtype" "ByLayer")
(setq clw(getvar "celweight"))
(setvar "celweight" -1)
(setq osm (getvar "osmode"))
(setvar "osmode" 513)
(setq dimz (getvar "dimzin"))
(setvar "dimzin" 0)
;;; ----------- < Системные переменные -------------;;
(princ "\nВыбрать кривую : ")
(if (setq sset (ssget "_:S:E:L" (list (cons 0 "spline,line,*polyline"))))
(progn
(setq pline (ssname sset 0))
(setq curh (getvar "textsize"))
(setq curst (getvar "textstyle"))
(initget "Да Нет Yes No")
(setq kw (getkword (strcat "\nИспользовать текущий стиль текста " "\"" curst "\"" " ? " " [Да/Нет] <Да>: ")))
(if (or (eq "No" kw)(eq "Нет" kw))
(if (not (eq ""
(setq curst (getstring t "\nВведите имя нужного стиля текста: "))))
(add-textsyle adoc curst "simplex" nil nil 0.0 0.8);<-- измени имя шрифта здесь ----------------
)
)
(initget 6)
(setq hgt (getreal (strcat "\nЗадайте высоту текста <" (rtos curh 2 1) ">: ")))
(if (not hgt)(setq hgt curh))
(initget 6)
(setq prec (getint (strcat "\nЗадайте число десятичных знаков <3>: ")))
(if (not prec)(setq prec 3))
(while (setq pick (getpoint "\nУказать точку на кривой (Enter для завершения): "))
(setq plpt (vlax-curve-getclosestpointto pline pick))
(setq par (vlax-curve-getparamatpoint pline plpt))
(setq dist (vlax-curve-getdistatparam pline par))
(setq fd (vlax-curve-getfirstderiv pline par))
(setq ang (angtangent pline plpt)
degs (* 180 (/ ang pi)))
(setvar "osmode" 512)
(setq txtp (getpoint "\nУказать положение текста на кривой : "))
(setq txtp (vlax-curve-getclosestpointto pline txtp))
(setq da (right-ang (angtangent pline txtp)))
(setq txtp (polar txtp (+ da (/ pi 2))(/ hgt 2)))
(princ (strcat "\nX : " (rtos (car plpt) 2 prec)
"\nY : " (rtos (cadr plpt) 2 prec)
"\nZ : " (rtos (caddr plpt) 2 prec)
"\nРасстояние : " (rtos dist 2 prec)
"\nУгол : " (rtos degs 2 prec)))
(setq mtx (vla-addmtext acsp (vlax-3d-point txtp) 0.0 (rtos dist 2 prec)))
(vla-put-attachmentpoint mtx acattachmentpointbottomcenter)
(vla-put-insertionpoint mtx (vlax-3d-point txtp))
(vla-put-height mtx hgt)
(vla-put-rotation mtx da)
(vla-put-stylename mtx curst)
(setvar "osmode" 513)
)
)
)
(vla-endundomark adoc)
(*error* nil)
(princ)
)
(prompt "\n --- команда на выполнение \"DISTAN\" или \"distan\" ---")
(prin1)
(or (vl-load-com)
(princ)
)
;;---------------------------------- end of distan.lsp --------------------------------;;
[FONT=Arial]~'J'~[/FONT]