Тема: Отмерить по линии расстояние и поставить точку

Ребята, друзья, программисты, Lisp нужен, чтоб по линии (отрезок, сплайн, полилиния) отмерял заданное с клавы расстояние (с учетом кривизны) от указанного мышкой места линии и ставил там точку.

"Разметить" не подходит.

Дай вам Бог Здоровьечка, кто поможет!

Re: Отмерить по линии расстояние и поставить точку

Попробуй такой вариант:

(defun C:PCUR (/ acsp adoc dist endist ent osm pdir pnt pt sign sset start tmpdist)
  (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-startundomark adoc)
 (setq osm (getvar "osmode" ))
 (setvar "osmode" 513)
(setq pt (getpoint "\nУказать точку на кривой : "))
(setq sset (ssget pt (list (cons 0 "spline,line,*polyline")))
      ent (ssname sset 0 )
    
     pt (vlax-curve-getclosestpointto ent pt)
     start (vlax-curve-getdistatpoint ent pt)
                        )
(setvar "osmode" 0)
(setq pdir (getpoint pt "\nУказать направление вдоль кривой >> ")
      pdir (vlax-curve-getclosestpointto ent pdir)
    tmpdist (vlax-curve-getdistatpoint ent pdir))
(if (> start tmpdist)
  (setq sign -)
  (setq sign +))
(initget 7)
(setq dist (getreal "\nВведите расстояние: "))
(setq endist (sign start dist))
(setq pnt (vlax-curve-getpointatdist ent endist))
  (setvar "pdmode" 34)
  (setvar "pdsize" -2)
(vl-catch-all-apply 'vlax-invoke (list acsp 'addpoint pnt))
(vla-endundomark adoc)
(princ)
)
(prompt "\n   ---   команда на выполнение \"PCUR\"   ---")
(prin1)
(or (vl-load-com)
(princ)    )

Re: Отмерить по линии расстояние и поставить точку

Ух ты!!! Это то что нужно!
Только привязку бы еще расширить. То есть сначала мы выбираем линию для отмерки, затем выбираем точку начала отсчета так, чтобы срабатывала любая привязка (пересечение, узел и т.д.) к объектам пересекающим линию или лежащим на ней.
:)

Re: Отмерить по линии расстояние и поставить точку

:cry: Куда же вы пропали, Fixo? :cry:

(изменено: Владимир Азарко, 8 февраля 2012г. 10:43:08)

Re: Отмерить по линии расстояние и поставить точку

Пробуй

(defun C:PCUR1 (/ acsp adoc dist endist ent osm pdir pnt pt sign sset start tmpdist) 
  (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-startundomark adoc) 
;;;(setq osm (getvar "osmode" )) 
;;;(setvar "osmode" 513)
(setq sset (ssget "_:S:E:L" (list (cons 0 "spline,line,*polyline")))
      ent (ssname sset 0 )
      pt (getpoint "\nУказать точку на кривой : ")
      pt (trans pt 1 0)
    pt (vlax-curve-getclosestpointto ent pt) 
    start (vlax-curve-getdistatpoint ent pt) 
                        )  
;;;(setvar "osmode" 0) 
(setq pdir (getpoint (trans pt 0 1) "\nУказать направление вдоль кривой >> ")
      pdir (trans pdir 1 0)
      pdir (vlax-curve-getclosestpointto ent pdir) 
   tmpdist (vlax-curve-getdistatpoint ent pdir)) 
(if (> start tmpdist) 
  (setq sign -) 
  (setq sign +)) 
(initget 7) 
(setq dist (getreal "\nВведите расстояние: ")) 
(setq endist (sign start dist)) 
(setq pnt (vlax-curve-getpointatdist ent endist)) 
  (setvar "pdmode" 34) 
  (setvar "pdsize" -2) 
(vl-catch-all-apply 'vlax-invoke (list acsp 'addpoint pnt)) 
(vla-endundomark adoc) 
(princ) 
) 
(prompt "\n   ---   команда на выполнение \"PCUR1\"   ---") 
(prin1) 
(or (vl-load-com) 
(princ)
    )

Re: Отмерить по линии расстояние и поставить точку

Много лет программировал на VBA и не смог сделать подобную программу. Начал изучать Lisp.
Можно ли добавить в программу вставку блока (все как в команде measure), например по сплайну вставить на определенном расстоянии условный знак с выравниванием по сплайну? Даже в Geonics этого нет.
Еше было бы здорово решить обратную задачу: указать мышкой точку на сплайне, направление и программа бы
возвратила привязку, т.е. расстояние до выбранной точки от начала сплайна или полилинии. В Geonics подобная задача решается только после построения трассы и не совсем так как бы хотелось.Спасибо.
Программа <PCUR1> то что надо многим проектировщикам!

Re: Отмерить по линии расстояние и поставить точку

@

Владимир Азарко - 08-02-2012 10:43:08

Володя, спасибо
Совсем нет времени :)

Re: Отмерить по линии расстояние и поставить точку

Огромное Спасибо, Fixo! получилась действительно очень нужная вещь для проектировщиков.
Еще один маленький вопросик. В конце выполняется регенерация модели два раза.

Отмерить по линии расстояние и поставить точку

Можно ли исключить ее вообще в данном случае? План большой, подвисает секунд на 10-15.
Еще раз спасибо, что не прошли мимо! :)

Re: Отмерить по линии расстояние и поставить точку

Дмитрий Космос пишет:

Огромное Спасибо, Fixo! получилась действительно очень нужная вещь для проектировщиков.
Еще один маленький вопросик. В конце выполняется регенерация модели два раза.

 

Можно ли исключить ее вообще в данном случае? План большой, подвисает секунд на 10-15.
Еще раз спасибо, что не прошли мимо!

У меня тоже самое с большими чертежами, как избавиться не знаю :evil:

Re: Отмерить по линии расстояние и поставить точку

Vladimir Mich пишет:

Много лет программировал на VBA и не смог сделать подобную программу. Начал изучать Lisp.
Можно ли добавить в программу вставку блока (все как в команде measure), например по сплайну вставить на определенном расстоянии условный знак с выравниванием по сплайну? Даже в Geonics этого нет.
Еше было бы здорово решить обратную задачу: указать мышкой точку на сплайне, направление и программа бы
возвратила привязку, т.е. расстояние до выбранной точки от начала сплайна или полилинии. В Geonics подобная задача решается только после построения трассы и не совсем так как бы хотелось.Спасибо.
Программа <PCUR1> то что надо многим проектировщикам!

Попробуй, если я правильно понял второпях

(defun C:PiK (/ acsp adoc ang bname dist endist ent osm pdir pnt pt sset start tmpdist)
  
  (defun angtangent (pline pt)
  ;; by CAB (Charles Alan Butler)
  (angle
    '(0 0 0)
    (trans
      (vlax-curve-getFirstDeriv
        pline
        (vlax-curve-getParamAtPoint pline (trans pt 1 0))
      )
      0 1 T 
    )
  )
)
  (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)
  (setq bname (getstring T "\nИмя блока : "))
(if (not (tblsearch "block" bname))
  (progn
    (alert (strcat "Блок " "\"" bname "\"" " не существует\nВыход из программы..."))
    (exit)(princ)))
(setq osm (getvar "osmode" )) 

(setq sset (ssget "_:S:E:L" (list (cons 0 "spline,line,*polyline"))) 
      ent (ssname sset 0 ) 
      pt (getpoint "\nУказать точку на кривой : ") 
      pt (trans pt 1 0) 
    pt (vlax-curve-getclosestpointto ent pt) 
    start (vlax-curve-getdistatpoint ent pt) 
                        )   
(setvar "osmode" 513) 
(setq pdir (getpoint (trans pt 0 1) "\nУказать направление вдоль кривой >> ") 
      pdir (trans pdir 1 0) 
      pdir (vlax-curve-getclosestpointto ent pdir) 
   tmpdist (vlax-curve-getdistatpoint ent pdir)) 
(if (> start tmpdist) 
  (setq sign -) 
  (setq sign +)) 
(initget 7) 
(setq dist (getreal "\nВведите расстояние: ")) 
(setq endist (sign start dist))
 
(setq pnt (vlax-curve-getpointatdist ent endist))
  (setq ang (angtangent ent pnt))
  (setvar "regenmode" 1)
  (setvar "pdmode" 34) 
  (setvar "pdsize" -2)
(setq blk (vl-catch-all-apply 'vlax-invoke (list acsp 'InsertBlock pnt bname 1.0 1.0 1.0 ang)))
  (initget "Да Нет Yes No")
(setq kw (getkword "\nРазвернуть блок ? [Да/Нет] <Нет>: "))

(if (or (eq "Да" kw)(eq "Yes" kw))
  (vl-catch-all-apply 'vlax-invoke (list blk 'Rotate pnt pi)))
(setvar "osmode" osm)
(vla-endundomark adoc) 
(princ) 
) 
(prompt "\n   ---   команда на выполнение \"PIK\" или \"pik\"  ---") 
(prin1) 
(or (vl-load-com) 
(princ) 
    )

[FONT=Arial]~'J'~[/FONT]

Re: Отмерить по линии расстояние и поставить точку

Огромное спасибо! Очень многие пользователи AutoCAD-a возьмут на вооружение эту программу.
Было-бы здорово, если бы Вы когда-нибудь решили еще и обратную задачу: определение расстояния до выбранной точки на сплайне или криволинейной п-линии. В "ручную" я эту задачу решаю следующим образом:
разрываю сплайн в точке и смотрю свойства или провожу новый сплайн поверх старого до нужной тоски и смотрю его свойства. Такая программа пригодилась бы многим геодезистам при работе с линейными объектами. Спасибо!

Re: Отмерить по линии расстояние и поставить точку

Vladimir Mich пишет:

Огромное спасибо! Очень многие пользователи AutoCAD-a возьмут на вооружение эту программу.
Было-бы здорово, если бы Вы когда-нибудь решили еще и обратную задачу: определение расстояния до выбранной точки на сплайне или криволинейной п-линии. В "ручную" я эту задачу решаю следующим образом:
разрываю сплайн в точке и смотрю свойства или провожу новый сплайн поверх старого до нужной тоски и смотрю его свойства. Такая программа пригодилась бы многим геодезистам при работе с линейными объектами. Спасибо!

Расстояние от какой точки до выбранной?
от начала кривой? или от произвольной точки?
или от предварительно указанного одного из концов кривой?
Подробнее...

[FONT=Arial]~'J'~[/FONT]

Re: Отмерить по линии расстояние и поставить точку

Подробнее...
Задача следующая:
1.Пользователь указывает сплайн или п-линию
2.Указывается начальная точка на сплайне (точка отсчета, но не обязательно это будет начало или конец)
3.Указывается направление
4.Указывается точка для которой нужно определить привязку (т.е. длину сплайна от первой точки до указанной)
         Программа работает и возвращает пользователю длину и предлагает указать точку мышкой для вывода результата и может быть предлагается указать мышкой угол, под которым текст будет выведен на экран. Спасибо! На VBA я не смог решить эту задачу.

Re: Отмерить по линии расстояние и поставить точку

Vladimir Mich пишет:

Подробнее...
Задача следующая:
1.Пользователь указывает сплайн или п-линию
2.Указывается начальная точка на сплайне (точка отсчета, но не обязательно это будет начало или конец)
3.Указывается направление
4.Указывается точка для которой нужно определить привязку (т.е. длину сплайна от первой точки до указанной)
Программа работает и возвращает пользователю длину и предлагает указать точку мышкой для вывода результата и может быть предлагается указать мышкой угол, под которым текст будет выведен на экран. Спасибо! На VBA я не смог решить эту задачу.

Для начала проверь такую поделку (считает только от начала кривой):
Сверь с известными точными результатами, используй привязки при указании точек

;;---------------------------------------------------------------------;;
;; distan.lsp
;; fixo () 2011 * all rights released
(defun C:distan(/ ang dimz dist fd osm par pick pline plpt sset)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setvar "dimzin" 0)
 (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))
(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 (angle (list 0 0 0) fd)
      degs (* 180 (/ ang pi)))
 ( setq p2 (polar pick ang 5))
  (command "_line" pick p2 "")
(alert (strcat "X : " (rtos (car plpt) 2 6)
           "\nY : " (rtos (cadr plpt) 2 6)
           "\nZ : " (rtos (caddr plpt) 2 6)
           "\nРасстояние : " (rtos dist 2 6)
           "\nУгол : " (rtos degs 2 6)))
  )
)
       )
(setvar "dimzin" dimz)
(setvar "osmode" osm)
(princ)
)
(prompt "\n   ---   команда на выполнение \"DISTAN\" или \"distan\"  ---") 
(prin1) 
(or (vl-load-com) 
(princ) 
    )
;; end of distan.lsp
;;---------------------------------------------------------------------;;

[FONT=Arial]~'J'~[/FONT]

(изменено: Дмитрий Космос, 12 февраля 2012г. 01:20:47)

Re: Отмерить по линии расстояние и поставить точку

Большое спасибо, Fixo, за distan
Очень давно искал именно эту задачу.

Если позволите, выношу на ваш суд несколько изменений в строчках вашего кода для вывода цифры в чертеж.
Мне нужна только длина, поэтому получилось следующее:

;;---------------------------------------------------------------------;; 
;; distan1.lsp 
;; fixo () 2011 * all rights released 
(defun C:distan1(/ ang dimz dist fd osm par pick pline plpt sset) 
(setq osm (getvar "osmode")) 
(setvar "osmode" 15295) 
(setvar "dimzin" 0) 
(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)) 
(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 (angle (list 0 0 0) fd) 
      degs (* 180 (/ ang pi))) 
( setq p2 (polar pick ang 5)) 
  (command "_line" pick p2 "") 
(if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0) ;_ end of =
(progn ;; нулевая высота текста
(if (not (setq txt_height (getreal "\nВведите высоту текста <2.5> : ")))(setq txt_height 2.5))
(vl-cmdf "_.TEXT" "0,0" txt_height 0 (rtos dist 2 2))) ;_ end of progn
(progn ;; фиксированнная высота
(vl-cmdf "_.TEXT" "0,0" 0 (rtos dist 2 2))) ;_ end of progn
)
(command "_.copybase" "0,0" (entlast) "" "_.erase" (entlast) "" "_.pasteclip" pause)
(princ)
)
  ) 
) 
      ) 
(setvar "dimzin" dimz) 
(setvar "osmode" osm) 
(princ) 
) 
(prompt "\n   ---   команда на выполнение \"DISTAN1\" или \"distan1\"  ---") 
(prin1) 
(or (vl-load-com) 
(princ) 
    ) 
;; end of distan1.lsp 
;;---------------------------------------------------------------------;;

Re: Отмерить по линии расстояние и поставить точку

Дмитрий,
Рад если это полезно для работы
эти 2 строчки можно удалить, я их оставил только для
наглядности как считает касательный угол в точке:

( setq p2 (polar pick ang 5)) 
  (command "_line" pick p2 "")


И ещё я уже указал что это только черновик, если нужно
что-то добавить или изменить - милости прошу

Re: Отмерить по линии расстояние и поставить точку

Спасибо, Fixo!  То что нужно. Уверен многие проектировщики скажут вам ОГРОМНОЕ СПАСИБО за новую команду AutoCAD. Десять лет не мог понять, почему этого нет в AutoCAD-е.

(изменено: fixo, 15 февраля 2012г. 13:36:31)

Re: Отмерить по линии расстояние и поставить точку

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]

Re: Отмерить по линии расстояние и поставить точку

Мой вариант здесь Расстояние от начала полилинии до опеделенной точки

Re: Отмерить по линии расстояние и поставить точку

День добрый, fixo. Почему-то код (#18) не работает до конца. Командная строка пишет:

Команда: distan3

Выбрать кривую :
Выберите объекты:

Использовать текущий стиль  текста "Standard" ?  [Да/Нет] <Да>: Д

Задайте высоту текста <2.5>:

Задайте число десятичных знаков <3>: 2

Указать точку на кривой (Enter для завершения):
Указать положение текста на кривой :
Distan3 Command Error: неверный тип аргумента: numberp: nil

Владимир Азарко, Спасибо!  :) Но у вас к сожалению нет возможности сначала выбора полилинии. Если нужна длина одной из пересекающихся полилиний, как выбрать нужную?

Re: Отмерить по линии расстояние и поставить точку

Я прямо сейчас скопировал код из поста #18
и всё работает без проблем, не знаю в чём дело,
может я не учёл какие-то переменные, а у тебя
другие значения этих переменных
Проверял на всех тирах полилиний, линий  и сплайнов
замкнутых и разомкнутых - всё пучком
Посмотрю ещё, может найду причину

[FONT=Arial]~'o'~[/FONT]

Re: Отмерить по линии расстояние и поставить точку

Я прошу прощения, влезу :) nil возвращается в:

(setq hgt (getreal (strcat "\nЗадайте высоту текста <" (rtos curh 2 1) ">: ")))

при выборе значения по умолчанию. Можно добавить после:

(or hgt (setq hgt curh))

Re: Отмерить по линии расстояние и поставить точку

Дмитрий Космос пишет:

Но у вас к сожалению нет возможности сначала выбора полилинии.

Теперь есть такая возможность :)

(изменено: fixo, 15 февраля 2012г. 13:39:06)

Re: Отмерить по линии расстояние и поставить точку

ciril пишет:

(or hgt (setq hgt curh))

Ценное замечание, спасибо :)
Код выше изменил, видимо потерял при копировании


@Dmitry:
Пробуй ещё раз :)

[FONT=Arial]~'J'~[/FONT]

Re: Отмерить по линии расстояние и поставить точку

fixo пишет:

@Dmitry: Пробуй ещё раз smile:)

Все, работает! Спасибо! Уже применяю в работе. Очень полезно. :)

Владимир Азарко, спасибо, с выносками тоже отлично!  :)