Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Доброго времени суток всем. Мои действия пошагово. Загрузил программу, вставил указанную строку кода в командную и в результате ((("_>. Выбор неактивен. Может быть это из-за версии программы. Сервис пака ведь еще нет. К сожалению ниже версии для проверки нет. Но в любом случае, спасибо за отзывчивость.Россиян с Праздником!
Доброго времени суток всем. Мои действия пошагово. Загрузил программу, вставил указанную строку кода в командную и в результате ((("_>. Выбор неактивен. Может быть это из-за версии программы. Сервис пака ведь еще нет. К сожалению ниже версии для проверки нет. Но в любом случае, спасибо за отзывчивость.Россиян с Праздником!
Просто выдели объект и смотри как он обзывается в свойствах
[FONT=Arial]~'J'~[/FONT]
Здравствуйте!
Вы писали:
10-06-2012 22:13:14
Vladimir, начни отсюда:
Работает, то только не входя в цикл, один раз. Может я что не так запускал, завтра еще несколько раз проверю. Запускал блок на только на сплайн.
Исправляю ошибки в сообщении: я тестировал Ваш код только на сплайне.
Исправляю ошибки в сообщении: я тестировал Ваш код только на сплайне.
1. Какой цикл? Команда для работы с единичным объектом
2. Возможно сплайн некомпланарный
Немного добавил, проверь еще раз
;; written by Fatty T.O.H. () 2004 * all rights removed
;; edited 6/5/10
;; edited 6/10/11
;; edited 6/11/11
;; edited 6/10/12
;; edited 6/12/12
;; Пикеты
;;load ActiveX library
(vl-load-com)
;;local defuns
;;//
(defun start (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getstartpoint curve
)
)
)
)
)
)
;;//
(defun end (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getendpoint curve
)
)
)
)
)
)
;;//
(defun pointoncurve (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
pt
)
)
)
)
)
;;//
(defun paramatpoint (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getparamatpoint curve
pt
)
)
)
)
)
;;//
(defun distatpt (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatpoint curve
(vlax-curve-getclosestpointto curve pt)
)
)
)
)
)
;;//
(defun pointatdist (curve dist)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getpointatdist curve dist)
)
)
)
)
)
;;//
(defun curvelength (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatparam curve
(- (vlax-curve-getendparam curve)
(vlax-curve-getstartparam curve)
)
)
)
)
)
)
;;//
(defun distatparam (curve param)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatparam curve
param
)
)
)
)
)
;;//
(defun statlabel (num step div)
;; num - integer, zero based
;; step - double or integer, must be non zero
(strcat
(itoa (fix (/ num div)))
"+"
(if (zerop (rem num div))
"00"
(rtos (* (rem num div) step) 2 0))
)
)
;;// written by VovKa (Vladimir Kleshev)
(defun gettangent (curve pt)
(setq param (paramatpoint curve pt)
ang ((lambda (deriv)
(if (zerop (cadr deriv))
(/ pi 2)
(atan (apply '/ deriv))
)
)
(cdr (reverse
(vlax-curve-getfirstderiv curve param)
)
)
)
)
ang
)
;;---------------------- main program -----------------------------;;
(defun c:DPK (/ *error* acsp adoc block cnt div en ent label
lastp lay leng lnum mul num pt rot sign start step txh txt)
(defun *error* (msg)
(vla-endundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(cond ((not msg))
((vl-position
msg
'("Function cancelled" "quit / exit abort" "console break")
)
)
((princ (strcat "\nDPK Command Error: " msg)))
)
(if clay
(setvar "celayer" clay)
)
(if dimz
(setvar "dimzin" dimz)
)
(princ)
)
(setvar "dimzin" 2)
(setq lay (getvar "clayer"))
(setvar "clayer" "0")
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
acsp (vla-get-block (vla-get-activelayout adoc))
)
(while (not
(and
(or
(initget 6)
(setq step (getreal "\nВведите шаг <25>: "))
(if (not step)
(setq step 25.)))
(zerop (rem 100 step))))
(alert (strcat "\nОстаток от деления 100 на шаг / " (rtos step 2 2) " не равен нулю,
\nВведен некорректный шаг"))
)
(initget "Yes No ")
(setq ans (getkword "\nВставить префикс? (Y/N) <Y>:"))
(setq pref (if (not ans )(lisped "ПК") ""))
(setq txh (cond
((getdist (strcat "\nВведите высоту текста [ Enter для подтверждения ]: <" (rtos (getvar "dimtxt") 2 1) ">: ")))
(txh)
))
(if
(setq
ent (entsel
"\nУказать кривую ближе к её началу >>"
)
)
(progn
(setq en (car ent)
obj (vlax-ename->vla-object en))
;; чёрная дыра:
(if (and (eq "AcDbSpline" (vla-get-objectname obj))(eq :vlax-false (vla-get-isplanar obj)))
(progn
(alert "Не работает с некомпланарными сплайнами\n Выход...")
(exit)(princ))
)
(setq pt (pointoncurve en (cadr ent))
leng (distatparam en (vlax-curve-getendparam en))
)
(setq num (fix (/ leng step))
)
(setq div (fix (/ 100. step)
)
)
(setq mul (- leng
(* (setq lnum (fix (/ leng (* step div)))) (* step div))))
(if (not (zerop mul))
(setq lastp T)
(setq lastp nil)
)
(if (> (- (paramatpoint en pt)
(paramatpoint en (vlax-curve-getstartpoint en))
)
(- (paramatpoint en (vlax-curve-getendpoint en))
(paramatpoint en pt)
)
)
(progn
(setq start leng
sign -1
)
)
(progn
(setq start (distatparam en (vlax-curve-getstartparam en))
sign 1
)
)
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(setq cnt 0)
(repeat (1+ num)
(setq pt (pointatdist en start)
rot (gettangent en pt)
)
(setq txt (vla-addtext acsp (strcat pref (statlabel cnt step div)) (vlax-3d-point pt) txh))
(vla-put-rotation txt (+ rot(/ pi 2)))
(setq cnt (1+ cnt)
start (+ start (* sign step))
)
)
(if lastp
(progn
(if (= sign -1)
(progn
(setq pt (vlax-curve-getstartpoint en)
rot (gettangent en pt)
)
)
(progn
(setq pt (vlax-curve-getendpoint en)
rot (gettangent en pt)
)
)
)
(setq label (strcat (itoa lnum) "+" (rtos mul 2 2))
)
(setq txt (vla-addtext acsp (strcat pref label) (vlax-3d-point pt) txh))
(vla-put-rotation txt (+ rot(/ pi 2)))
)
)
)
(princ "\nНичего не выбрано")
)
(*error* nil)
(princ)
)
(prompt "\n --- Команда на выполнение \"DPK\" или \"dpk\" ---")
(prin1)
(or (vl-load-com)
(princ)
)[FONT=Arial]~'J'~[/FONT]
Спасибо!
Все работает. Протестирую при использовании в работе с планами. Программа очень полезная, не нужно создавать трассу и выполнять кучу настроек (как в GeoniCS )
Рад помочь,
[FONT=Arial]~'J'~[/FONT]
Здравствуйте fixo!
Успешно применяю Ваши программы при решении ряда задач. Очень хотелось бы изменить формат вывода расстояний по сплайну ((код #18), https://www.caduser.ru/forum/post276927.html#p276927)
Мне нужно, чтобы расстояние выводилось в формате не 567.56 а п5+67.56 или ПК5+67.56, то есть с префиксом, как в коде из #80
(https://www.caduser.ru/forum/post278181.html#p278181)
Спасибо.
Здравствуйте fixo!
Успешно применяю Ваши программы при решении ряда задач. Очень хотелось бы изменить формат вывода расстояний по сплайну ((код #18), https://www.caduser.ru/forum/)
Мне нужно, чтобы расстояние выводилось в формате не 567.56 а п5+67.56 или ПК5+67.56, то есть с префиксом, как в коде из #80
(https://www.caduser.ru/forum/)
Спасибо.
Посмотрю попозже, как освобожусь,
сейчас доделываю большую программу для своих нужд
[FONT=Arial]~'J'~[/FONT]
Мне нужно, чтобы расстояние выводилось в формате не 567.56 а п5+67.56 или ПК5+67.56, то есть с префиксом, как в коде из #80
Vladimir,
Собрал из двух, попробуй, имя команды заменил,
заменил также многострочный текст на простой:
;;--------------------------------- dpick.lsp ------------------------------------;;
;; fixo () 2012 * all rights released
;; редакция от 08 авг. 2012
;; редакция от 14 авг. 2012
(defun C:DPICK(/ *error* acsp adoc ang ans clay clr clt clw curh curst curve da degs dimz dist div fd hgt kw layerobj
leng lnum mul num obj osm par param pick pline plpt prec pref pt sset step style styles txt txtp)
;;;
(defun *error* (msg)
(if adoc(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)
)
(defun distatparam (curve param)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatparam curve
param
)
)
)
)
)
;;;
(defun pointoncurve (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
pt
)
)
)
)
)
;;; ------------------------------ Основная программа -----------------------------------;;
(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 (cadar (ssnamex sset 0)))
(setq pt (last (cadddr (last (ssnamex sset 0)))))
;;------------------------------------------------
(setq obj (vlax-ename->vla-object pline))
;; чёрная дыра:
(if (and (eq "AcDbSpline" (vla-get-objectname obj))(eq :vlax-false (vla-get-isplanar obj)))
(progn
(alert "Не работает с некомпланарными сплайнами\n Выход...")
(exit)(princ))
)
(setq pt (pointoncurve pline pt)
leng (distatparam pline (vlax-curve-getendparam pline))
)
(while (not
(and
(or
(initget 6)
(setq step (getreal "\nВведите шаг <25>: "))
(if (not step)
(setq step 25.)))
(zerop (rem 100 step))))
(alert (strcat "\nОстаток от деления 100 на шаг / " (rtos step 2 2) " не равен нулю,
\nВведен некорректный шаг"))
)
(setq num (fix (/ leng step))
)
(setq div (fix (/ 100. step)
)
)
(setq mul (- leng
(* (setq lnum (fix (/ leng (* step div)))) (* step div))))
;;---------------------------------------------
(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 "Yes No ")
(setq ans (getkword "\nВставить префикс? (Y/N) <Y>:"))
(setq pref (if (not ans )(lisped "ПК") ""))
(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" 513)
(setq txtp plpt)
(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 txt (vla-addtext acsp
(if (< dist step)(strcat pref "0+" (if (< (fix (- dist (* (fix (/ dist step)) step))) 10)"0" "")(rtos dist 2 prec))
(strcat pref (itoa (fix (/ dist step)))"+"
(if (< (fix (- dist (* (fix (/ dist step)) step))) 10)"0" "")
(rtos (- dist (* (fix (/ dist step)) step))2 prec)))
(vlax-3d-point txtp)
hgt)
)
(vla-put-alignment txt acalignmentbottomcenter)
(vla-put-textalignmentpoint txt (vlax-3d-point txtp))
(vla-put-insertionpoint txt (vla-get-textalignmentpoint txt))
(vla-put-rotation txt da)
(vla-put-stylename txt curst)
(setvar "osmode" 513)
)
)
)
(vla-endundomark adoc)
(*error* nil)
(princ)
)
(prompt "\n --- команда на выполнение \"DPICK\" или \"dpick\" ---")
(prin1)
(or (vl-load-com)
(princ)
)
;;---------------------------------- end of dpick.lsp --------------------------------;;[FONT=Arial]~'J'~[/FONT]
Спасибо Уважаемый fixo!
Все работает, но приходиться переформатировать некоторые полученные данные:
- формат чисел с префиксом. Нужно,чтобы было например ПК5+04.12, а не ПК5+4.12, т.е нужен формат "#####0.00.00";
-настройка привязок пользователя не должна меняться. Мне не подходит "близжайшая", т.к. нужна точная привязка;
-текстовые объекты (например ПК12+05.08, должны выводиться в виде однострочного текста, точно также, как это делается в Вашей программе (https://www.caduser.ru/forum/)
Спасибо. Буду очень благодарен, если найдете время для дальнейшей доработки программы.
Это сложно для меня, надо будет разжевать,
вернусь попозже
Приложи чертежик с точными пикетами (пару пикетов для теста)
[FONT=Arial]~'J'~[/FONT]
Короче, я получаю такие результаты
ПК0+96.565
ПК1+89.169
ПК3+50.227
ПК4+81.396
Распиши построчно, какие должны быть
ПК0+96.565
ПК1+89.169
ПК3+50.227
ПК4+81.396
Здесь все нормально, нужен только однострочный текст и настройка привязок не должна меняться.
Программа выводит формат ПК0+1.564 ,нужно ПК0+01.564,
или ПК12+7.12, а нужно ПК12+07.12
Спасибо.
Изменил код выше, пробуй снова,
привязки цепляй вручную, их установить
заочно невозможно
[FONT=Arial]~'J'~[/FONT]
fixo спасибо за лисп,а можно его немного переделать под определенные задачи:
-выбирам полилинию
-выбираем тестовый стиль
-выбираем высоту текста
-лисп проставляет к каждому сегменту полилинии выноску с его длиной
fixo спасибо за лисп,а можно его немного переделать под определенные задачи:
-выбирам полилинию
-выбираем тестовый стиль
-выбираем высоту текста
-лисп проставляет к каждому сегменту полилинии выноску с его длиной
Извини сейчас очень занят, совсем не могу помочь,
как освобожусь, тогда сделаю
лисп проставляет к каждому сегменту полилинии выноску с его длиной
Пробуй:
(defun C:LS(/ *error* acsp dist en end mlead nextpt pt pts sfar ss start txtht txtstyle)
(vl-load-com)
(defun *error* (msg)
(if adoc (vla-endundomark adoc))
(cond ((not msg)) ; Normal exit
((member msg '("Function cancelled" "quit / exit abort"))) ; <esc> or (quit)
((princ (strcat "\n** Error: " msg " ** "))) ; Fatal error, display it
)
(princ)
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(if (and (setq txtstyle (getstring "\nEnter a text style: "))
(setq txtht (getreal "\nEnter a text height: ")))
(progn
(setq acsp
(vla-get-block
(vla-get-activelayout
adoc)))
(vla-startundomark adoc)
(princ "\n\t--->\tВыбери полилинию: ")
(if
(setq ss (ssget ":S" '((0 . "*POLYLINE"))))
(progn
(setq en (ssname ss 0))
(setvar 'osmode 512)
(while (setq pt (getpoint "\nТочка на сегменте: "))
(setq start (fix (vlax-curve-getparamatpoint
en
(vlax-curve-getClosestPointTo en pt)))
end (1+ start))
(setq dist (- (vlax-curve-getdistatparam en end)
(vlax-curve-getdistatparam en start)))
(setq nextpt (getpoint pt "\nТочка текста: "))
(setq pts (list pt nextpt))
(setq sfar (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-VbDouble
(cons 0 (1- (* 3 (length pts))))
)
(apply 'append pts)
)
)
)
(setq mlead (vla-addmleader acsp sfar 0))
(vla-put-textstring mlead (rtos dist 2 2))
(vla-setdoglegdirection
mlead
0
(vlax-3D-point
(list
(if (<= (car pt) (car nextpt))
1
-1)
0
0
)
)
)
(if (>= (car nextpt) (car pt))
(vla-put-textjustify mlead acattachmentpointmiddleleft)
(vla-put-textjustify mlead acattachmentpointmiddleright)
)
(vla-put-textleftattachmenttype mlead acattachmentbottomoftopline)
(vla-put-textrightattachmenttype mlead acattachmentbottomoftopline)
(vla-put-leadertype mlead 1)
(vla-put-stylename mlead txtstyle) ;<-- text style name
(vla-put-textheight mlead txtht)
(vla-update mlead)
(setq pts nil)
)))))
(*error* nil)
(princ)
)собрал из старых лиспов, тестируй сам
fixo спасибо за оперативность,но лисп пишет "синтаксическая ошибка"
fixo спасибо за оперативность,но лисп пишет "синтаксическая ошибка"
Скопировал отсюда, обнаружилось в функции *error* откуда-то
появляется знак минус перед комментарием ";Normal exit"
Вставляю по-новой:
(defun C:LS(/ *error* acsp dist en end mlead nextpt pt pts sfar ss start txtht txtstyle)
(vl-load-com)
(defun *error* (msg)
(if adoc (vla-endundomark adoc))
(cond(( not msg )) ; Normal exit
((member msg '("Function cancelled" "quit / exit abort"))) ; <esc> or (quit)
((princ (strcat "\n** Error: " msg " ** ")))) ; Fatal error, display it
(princ)
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(if (and (setq txtstyle (getstring "\nEnter a text style: "))
(setq txtht (getreal "\nEnter a text height: ")))
(progn
(setq acsp
(vla-get-block
(vla-get-activelayout
adoc)))
(vla-startundomark adoc)
(princ "\n\t--->\tВыбери полилинию: ")
(if
(setq ss (ssget ":S" '((0 . "*POLYLINE"))))
(progn
(setq en (ssname ss 0))
(setvar 'osmode 512)
(while (setq pt (getpoint "\nТочка на сегменте: "))
(setq start (fix (vlax-curve-getparamatpoint
en
(vlax-curve-getClosestPointTo en pt)))
end (1+ start))
(setq dist (- (vlax-curve-getdistatparam en end)
(vlax-curve-getdistatparam en start)))
(setq nextpt (getpoint pt "\nТочка текста: "))
(setq pts (list pt nextpt))
(setq sfar (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-VbDouble
(cons 0 (1- (* 3 (length pts))))
)
(apply 'append pts)
)
)
)
(setq mlead (vla-addmleader acsp sfar 0))
(vla-put-textstring mlead (rtos dist 2 2))
(vla-setdoglegdirection
mlead
0
(vlax-3D-point
(list
(if (<= (car pt) (car nextpt))
1
-1)
0
0
)
)
)
(if (>= (car nextpt) (car pt))
(vla-put-textjustify mlead acattachmentpointmiddleleft)
(vla-put-textjustify mlead acattachmentpointmiddleright)
)
(vla-put-textleftattachmenttype mlead acattachmentbottomoftopline)
(vla-put-textrightattachmenttype mlead acattachmentbottomoftopline)
(vla-put-leadertype mlead 1)
(vla-put-stylename mlead txtstyle) ;<-- text style name
(vla-put-textheight mlead txtht)
(vla-update mlead)
(setq pts nil)
)))))
(*error* nil)
(princ)
)
Ребята, я не особо силен в кодах и т.п.., но можно как-то в код из поста #5 внедрить чтобы вместо точки он ставил блок или отрезок определенной длины перпендикулярно размечаемой полилинии?!.. :!: :!: :!: :oops:
Форум работает на PunBB, при поддержке Informer Technologies, Inc
