| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > AutoCAD > Расстояние от начала полилинии до опеделенной точки

Расстояние от начала полилинии до опеделенной точки

Ответ
Поиск в этой теме
Непрочитано 20.10.2006, 15:53 #1
Расстояние от начала полилинии до опеделенной точки
bimari
 
проектирование дорог
 
Riga
Регистрация: 18.10.2006
Сообщений: 25

Подскажите, пожалуйста как в 2006 акаде можно было определить расстояние от начала полилинии до любой ее точки. Было бы хорошо, если бы кликнув на эту точку появлялся Leader с расстоянием. Заранее спасибо!
Просмотров: 9601
 
Непрочитано 20.10.2006, 16:25
#2
Zouss


 
Регистрация: 14.03.2006
Сообщений: 863


это вам в соседнюю ветку, где про среднюю линию, непосредственно к господам VVA и Лентяй, ибо в строках ихних прог видятся мне ростки решения
единственно уточните, что для вас является началом полилинии - точка с которой вы начинали построение этой самой полилинии или, в общем случае, одна из двух точек которые, если они в паре традиционно называют концами линии поли-ли или непили-ли
Zouss вне форума  
 
Непрочитано 20.10.2006, 17:31
#3
VVA

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


Пробуй
Код:
[Выделить все]
(defun C:DST ( / adoc *error* crvs eps dL pts pt1 pt2 ptc n osm)
(defun *error* (msg)(vl-cmdf "_redrawall")(vla-EndUndoMark adoc)
  (setvar "OSMODE" osm))
(defun dr_st ( pt ang color / pt1 pt2 )
  (setq pt1 (polar pt (+ ang 2.35619 ) (* 0.03 (getvar "VIEWSIZE"))))
  (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
  (grvecs (list color pt1 pt pt pt2)))
(defun dr_kr ( pt color / pt11 pt12 pt21 pt22 len )
(setq len (* 0.02 (getvar "VIEWSIZE"))
pt11 (polar pt 3.92699 len) pt12 (polar pt 0.785398 len)
pt21 (polar pt 5.49779 len) pt22 (polar pt 2.35619 len))
(grvecs (list color pt11 pt12 pt21 pt22)))  
(vl-load-com)(setq osm (getvar "OSMODE"))
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-StartUndoMark adoc)(setvar "CMDECHO" 0)(setvar "OSMODE" 512)
(setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
(if (setq ss (if pt (ssget pt '((0 . "*LINE,ARC"))) nil))
  (progn (setq en (ssname ss 0)
    crv (vlax-ename->vla-object en)
     pt (vlax-curve-getclosestpointto crv (trans pt 1 0))
     ds (vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv))
    ds1 (vlax-curve-getDistAtParam crv (vlax-curve-getParamAtPoint crv pt)))
   (dr_st (trans pt 0 1)(angle (trans pt 0 1)(trans
   (vlax-curve-getPointAtParam crv (+ (vlax-curve-getParamAtPoint crv pt) 0.0001))0 1))1)
   (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
   (initget "Поменять Change _C C")(princ "\nДлинна объекта ")(princ ds1)
   (princ " [Поменять начало] <готово>:")(setq en (getkword))	    
   (if (= en "C")(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
   (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
   (setq ds1 (- ds ds1))))(princ "\nВторая точка выноски :")
   (vl-cmdf "_LEADER" (trans pt 0 1) pause "" (rtos ds1 2 3) "")))
  (setvar "OSMODE" osm)(vla-EndUndoMark adoc)(vl-cmdf "_redrawall")(princ))
(princ "\nНаберите в командной строке DST")
VVA вне форума  
 
Непрочитано 20.10.2006, 17:36
#4
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,663


Интересно, Лентяй покороче сможет написать?
Profan вне форума  
 
Непрочитано 20.10.2006, 17:45
#5
Zouss


 
Регистрация: 14.03.2006
Сообщений: 863


хы, великая идея измерений у кого длиннее приобретает смысл прямопротивоположный изначальному
пожалуй я смогу написать эту прогу за 30 строк ?)
Zouss вне форума  
 
Автор темы   Непрочитано 25.10.2006, 09:33
#6
bimari

проектирование дорог
 
Регистрация: 18.10.2006
Riga
Сообщений: 25


Спасибо огромное, именно то, что искала Очень облегчило работу!
bimari вне форума  
 
Непрочитано 17.01.2007, 04:53
#7
KAI

геологоразведка, строительство
 
Регистрация: 14.10.2003
Магадан
Сообщений: 311


>> VVA

Для достаточно больших координат объектов в WSC, например:
X=22685606.13397148 Y=5431154.563627330 Z=0.0000000000
Наблюдается следующая картина:
1. для линий и 2d и 3d полилиний Acad иногда не может найти параметры, особенно это проявляется в UCS, и соответственно программа вываливаетя.
2. сглаженные 2d и 3d полилинии дают меньше ошибок.
3. если координаты близки к 0,0.0 все работае как часы.
__________________
Лень - великий двигатель прогресса!
KAI вне форума  
 
Непрочитано 17.01.2007, 11:04
#8
VVA

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


> KAI
Когда здесь мы пытались заставить PL-DIV работать в UCS, то там глючила vlax-curve-getDistAtPoint. Пямятуя об этом в DST использовал vlax-curve-getDistAtParam. Мыслей никаких. Пришли почтой рисунок, посмотрю, что вылетает.
VVA вне форума  
 
Непрочитано 19.01.2007, 15:39
#9
VVA

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


Сбоила vlax-curve-getParamAtPoint, причем на каком-то участке возвращает параметр, на на каком-то нет
Пока выход нашел такой: line ,3d polyline, 2d и LW polyline не сглаженные и без дуговых сегментов обрабатываю по правилам геометрии (принадлежность точки прямой).

Код:
[Выделить все]
;http://forum.dwg.ru/showthread.php?p=113702#post113702
(defun C:DST (/ adoc *error* crvs eps dL pts pt1 pt2 ptc n osm vx p1 p2)
  (defun *error* (msg)(princ msg)(vl-cmdf "_redrawall")(vla-EndUndoMark adoc)
    (setvar "OSMODE" osm))
  (defun dr_st (pt ang color / pt1 pt2)
    (setq pt1 (polar pt (+ ang 2.35619) (* 0.03 (getvar "VIEWSIZE"))))
    (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
    (grvecs (list color pt1 pt pt pt2)))
  (defun dr_kr (pt color / pt11 pt12 pt21 pt22 len)
    (setq len  (* 0.02 (getvar "VIEWSIZE"))
	  pt11 (polar pt 3.92699 len)
	  pt12 (polar pt 0.785398 len)
	  pt21 (polar pt 5.49779 len)
	  pt22 (polar pt 2.35619 len))
    (grvecs (list color pt11 pt12 pt21 pt22)))
(defun getblg ( pl / blglist i n ent_data tmp_ent)
(setq ent_data (entget pl))
(cond ((= (cdr(assoc 0 ent_data)) "LWPOLYLINE")
  (setq  blglist (mapcar 'cdr (vl-remove-if-not(function(lambda(x)(= 42(car x)))) ent_data))))
(t (setq tmp_ent pl)
 (while (/= "SEQEND"  (cdr(assoc 0 (entget(setq tmp_ent (entnext tmp_ent))))))
  (setq  blglist (append blglist (list (cdr(assoc 42 (entget tmp_ent)))))))))
   blglist)
  (vl-load-com)(setq osm (getvar "OSMODE"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark adoc)
  (setvar "CMDECHO" 0)(setvar "OSMODE" 512)
  (setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
  (if (setq ss (if pt
		 (ssget pt '((0 . "*LINE,ARC")))
		 nil)
      )
    (progn
      (setq en	(ssname ss 0)
	    crv	(vlax-ename->vla-object en)
	    pt	(vlax-curve-getclosestpointto crv (trans pt 1 0))
	    ds	(vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv)))
      (cond ((= (vla-get-ObjectName crv) "AcDbLine")
	     (setq ds1 (distance (cdr(assoc 10 (entget en))) pt)))
	    ((or (= (vla-get-ObjectName crv) "AcDb3dPolyline")
                 (and
                     (= (vla-get-ObjectName crv) "AcDb2dPolyline")
                     (/= (logand (cdr(assoc 70 (entget en))) 2) 2) ;_Fit
                     (/= (logand (cdr(assoc 70 (entget en))) 4) 4) ;_Spline
                     (vl-every 'zerop (getblg en))
                     )
                 (and
                     (= (vla-get-ObjectName crv) "AcDbPolyline")
                     (vl-every 'zerop (getblg en))
                     )
                 )
	     (setq vx ((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam crv))
                       (setq lst (append lst (list (vlax-curve-getPointAtParam crv i))))) lst)))
	     (setq p1 (car vx) vx (cdr vx) ds1 0)
	     (while (and (setq p2 (car vx))
			 (not (equal (+ (distance Pt P1) (distance Pt P2)) (distance P1 P2) 0.00001))
			 )
	       (setq vx (cdr vx) ds1 (+ ds1 (distance P1 P2)) p1 p2)
	       )
	       (setq ds1 (+ ds1 (distance P1 Pt))))
	    (t (setq  ds1 (vlax-curve-getDistAtParam
			    crv (vlax-curve-getParamAtPoint crv pt)))))
      (dr_st (trans pt 0 1)
	     (angle (trans pt 0 1)
		    (trans (vlax-curve-getPointAtParam crv
			(+ (vlax-curve-getParamAtDist crv ds1) 0.0001))
		      0  1)) 1)
      (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
      (initget "Поменять Change _C C")
      (princ "\nДлинна объекта ")(princ ds1)
      (princ " [Поменять начало] <готово>:")(setq en (getkword))
      (if (= en "C")
	(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
	       (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
	       (setq ds1 (- ds ds1))
	)
      )
      (princ "\nВторая точка выноски :")
      (vl-cmdf "_LEADER"
	       (trans pt 0 1)
	       pause
	       ""
	       (rtos ds1 2 3)
	       "" )))
  (setvar "OSMODE" osm)
  (vla-EndUndoMark adoc)
  (vl-cmdf "_redrawall")
  (princ))
(princ "\nНаберите в командной строке DST")

Последний раз редактировалось VVA, 19.09.2015 в 21:09.
VVA вне форума  
 
Непрочитано 06.12.2010, 17:22
#10
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


Не смог разобраться, какая переменная из #9 хранит в себе значение длины полилинии от начала до указанной точки (указанная точка в данном случае хранится в переменной a)? Мне нужно создавать мультивыноску, содержащую имя слоя, на котором расположена полилиния и длину. Как выяснить имя слоя? Есть мысль проверять принадлежность точки полилинии и затем запрашивать имя ее слоя. Или можно проще?
Код:
[Выделить все]
(defun c:mymleader (/ a)
(setq a (getpoint "Укажите точку вставки выноски <Выход>: "))
(command "_mleader" a pause "_e" "0" (strcat "Имя слоя " "Длина"))
)
skkkk на форуме  
 
Непрочитано 06.12.2010, 18:09
1 | #11
VVA

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


Цитата:
Сообщение от skkkk Посмотреть сообщение
Не смог разобраться, какая переменная из #9 хранит в себе значение длины полилинии от начала до указанной точки
dsl
Цитата:
Сообщение от skkkk Посмотреть сообщение
Как выяснить имя слоя?
(vla-get-layer crv)
Обновленный вариант команды DST
Чертит текущим стилем мультивыноски
Код:
[Выделить все]
(defun C:DST (/ adoc *error* crvs eps dL pts pt1 pt2 ptc n osm vx p1 p2)
;;;http://forum.dwg.ru/showthread.php?p=113702#post113702 
  (defun *error* (msg)(princ msg)(vl-cmdf "_redrawall")(vla-EndUndoMark adoc)
    (setvar "OSMODE" osm))
  (defun dr_st (pt ang color / pt1 pt2)
    (setq pt1 (polar pt (+ ang 2.35619) (* 0.03 (getvar "VIEWSIZE"))))
    (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
    (grvecs (list color pt1 pt pt pt2)))
  (defun dr_kr (pt color / pt11 pt12 pt21 pt22 len)
    (setq len  (* 0.02 (getvar "VIEWSIZE"))
	  pt11 (polar pt 3.92699 len)
	  pt12 (polar pt 0.785398 len)
	  pt21 (polar pt 5.49779 len)
	  pt22 (polar pt 2.35619 len))
    (grvecs (list color pt11 pt12 pt21 pt22)))
(defun getblg ( pl / blglist i n ent_data tmp_ent)
(setq ent_data (entget pl))
(cond ((= (cdr(assoc 0 ent_data)) "LWPOLYLINE")
  (setq  blglist (mapcar 'cdr (vl-remove-if-not(function(lambda(x)(= 42(car x)))) ent_data))))
(t (setq tmp_ent pl)
 (while (/= "SEQEND"  (cdr(assoc 0 (entget(setq tmp_ent (entnext tmp_ent))))))
  (setq  blglist (append blglist (list (cdr(assoc 42 (entget tmp_ent)))))))))
   blglist)
  (vl-load-com)(setq osm (getvar "OSMODE"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark adoc)
  (setvar "CMDECHO" 0)(setvar "OSMODE" 512)
  (setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
  (if (setq ss (if pt
		 (ssget pt '((0 . "*LINE,ARC")))
		 nil)
      )
    (progn
      (setq en	(ssname ss 0)
	    crv	(vlax-ename->vla-object en)
	    pt	(vlax-curve-getclosestpointto crv (trans pt 1 0))
	    ds	(vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv)))
      (cond ((= (vla-get-ObjectName crv) "AcDbLine")
	     (setq ds1 (distance (cdr(assoc 10 (entget en))) pt)))
	    ((or (= (vla-get-ObjectName crv) "AcDb3dPolyline")
                 (and
                     (= (vla-get-ObjectName crv) "AcDb2dPolyline")
                     (/= (logand (cdr(assoc 70 (entget en))) 2) 2) ;_Fit
                     (/= (logand (cdr(assoc 70 (entget en))) 4) 4) ;_Spline
                     (vl-every 'zerop (getblg en))
                     )
                 (and
                     (= (vla-get-ObjectName crv) "AcDbPolyline")
                     (vl-every 'zerop (getblg en))
                     )
                 )
	     (setq vx ((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam crv))
                       (setq lst (append lst (list (vlax-curve-getPointAtParam crv i))))) lst)))
	     (setq p1 (car vx) vx (cdr vx) ds1 0)
	     (while (and (setq p2 (car vx))
			 (not (equal (+ (distance Pt P1) (distance Pt P2)) (distance P1 P2) 0.00001))
			 )
	       (setq vx (cdr vx) ds1 (+ ds1 (distance P1 P2)) p1 p2)
	       )
	       (setq ds1 (+ ds1 (distance P1 Pt))))
	    (t (setq  ds1 (vlax-curve-getDistAtParam
			    crv (vlax-curve-getParamAtPoint crv pt)))))
      (dr_st (trans pt 0 1)
	     (angle (trans pt 0 1)
		    (trans (vlax-curve-getPointAtParam crv
			(+ (vlax-curve-getParamAtDist crv ds1) 0.0001))
		      0  1)) 1)
      (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
      (initget "Поменять Change _C C")
      (princ "\nДлинна объекта ")(princ ds1)
      (princ " [Поменять начало] <готово>:")(setq en (getkword))
      (if (= en "C")
	(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
	       (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
	       (setq ds1 (- ds ds1))
	)
      )
      (princ "\nВторая точка выноски :")
      (if (getvar "CMLEADERSTYLE")
       (draw-mleader
         pt ;_ начальная точка
         pause ;_запрос второй точкм
         (list
           (strcat "Имя слоя " (vla-get-layer crv)) ;_1-я строка
           (strcat "Длина " (rtos ds1 2 3))  ;_2-я строка длина до 3 знаков после запятой
           )
          1.5 ;_Вытота текста
          0.87 ;_Значение коэффициента см
;;; тему http://forum.dwg.ru/showpost.php?p=656758&postcount=51
         0.2 ;_отступ 1-го параграфа (форматтирование \\pxa)
         )
      (vl-cmdf "_LEADER"
	       (trans pt 0 1)
	       pause
	       ""
	       (rtos ds1 2 3)
	       "" )
        )
      )
    )
  (setvar "OSMODE" osm)
  (vla-EndUndoMark adoc)
  (vl-cmdf "_redrawall")
  (princ))
  (defun draw-mleader (pt1 pt2 strlist Htxt koeff abz / dic mlst i)
  ;;; pt1 - начальная точка UCS
  ;;; pt2 - конечная точка UCS
  ;;; strlist - список строк
  ;;; Htxt - высота текста
  ;;; koeff - коэфф форматирования pxe или nil
  ;;; abz - коэфф форматирования абзаца \\pa или Nil
  ;;;(draw-mleader (setq pt1(getpoint))(getpoint pt1)(list "Пример" "Минскинжпроект" "Третья строка") 1.5 0.9 nil)
 ;;; Стиль мультивыноски текущий
  (setq i 0)
  (command
    "_mleader"
    "_h"
    "_none"
    pt1
    "_none"
    pt2
  (strcat (if koeff (strcat "\\px"
                              (if abz (strcat "a"(VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR abz))",") "")
                              "se" (VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR koeff))";") "")   ;;;"\\pxse0.87;"
;;;            "\\pa0.15;" (car strlist) "\\pa0;"
              (car strlist)
    )
    )
  (while (> (getvar "CMDACTIVE") 0) (command ""))
  (setq dic (vlax-ename->vla-object (entlast)))
  (vla-put-TextString dic
    (strcat (if koeff (strcat "\\px"
                              (if abz (strcat "a"(VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR abz))",") "")
                              "se" (VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR koeff))";") "")   ;;;"\\pxse0.87;"
;;;            "\\pa0.15;" (car strlist) "\\pa0;"
              (car strlist)
;;;              (if abz "\\pa0;" "")
            (apply 'strcat
                   (mapcar '(lambda (x) (strcat "\\P" (if (= (setq i (1+ i)) 1)(if abz "\\pa0;" "")   "")  x)) (cdr strlist))
            ) ;_ end of apply
    ) ;_ end of strcat
  )
    (vla-put-TextHeight dic Htxt)
    dic
  )
  (defun mip-conv-to-str (dat)
      (cond ((= (type dat) 'INT) (setq dat (itoa dat)))
            ((= (type dat) 'REAL) (setq dat (rtos dat 2 12)))
            ((null dat) (setq dat ""))
            (t (setq dat (vl-princ-to-string dat)))
      ) ;_ end of cond
    ) ;_ end of defun
(princ "\nНаберите в командной строке DST")
Вариант с запросом на предварительный выбор кривой
Код:
[Выделить все]
(defun C:DSTS (/ adoc *error* crvs eps dL pts pt1 pt2 ptc n osm vx p1 p2)
  ;;; Расстояние от начала полилинии до опеделенной точки
  ;;; Запрос выбора полилинии
  ;;; http://forum.dwg.ru/showthread.php?t=8713
  ;;; Отмерить по линии расстояние и поставить точку
  ;;; http://www.caduser.ru/forum/index.php?PAGE_NAME=read&FID=23&TID=49398
   (defun *error* (msg)(if mut (setvar 'NOMUTT mut))(princ msg)
    (vl-cmdf "_redrawall")(vla-EndUndoMark adoc)(setvar "OSMODE" osm))
  (defun dr_st (pt ang color / pt1 pt2)
    (setq pt1 (polar pt (+ ang 2.35619) (* 0.03 (getvar "VIEWSIZE"))))
    (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
    (grvecs (list color pt1 pt pt pt2)))
  (defun dr_kr (pt color / pt11 pt12 pt21 pt22 len)
    (setq len  (* 0.02 (getvar "VIEWSIZE"))
	  pt11 (polar pt 3.92699 len)
	  pt12 (polar pt 0.785398 len)
	  pt21 (polar pt 5.49779 len)
	  pt22 (polar pt 2.35619 len))
    (grvecs (list color pt11 pt12 pt21 pt22)))
(defun getblg ( pl / blglist i n ent_data tmp_ent)
(setq ent_data (entget pl))
(cond ((= (cdr(assoc 0 ent_data)) "LWPOLYLINE")
  (setq  blglist (mapcar 'cdr (vl-remove-if-not(function(lambda(x)(= 42(car x)))) ent_data))))
(t (setq tmp_ent pl)
 (while (/= "SEQEND"  (cdr(assoc 0 (entget(setq tmp_ent (entnext tmp_ent))))))
  (setq  blglist (append blglist (list (cdr(assoc 42 (entget tmp_ent)))))))))
   blglist)
  (vl-load-com)(setq osm (getvar "OSMODE"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark adoc)
  (setvar "CMDECHO" 0)
  (and
      (progn
        (setq mut (getvar 'NOMUTT))
        (setvar 'NOMUTT 1)
        (princ "\nВыберите кривую: ")
        (setq ss (ssget "_:E:S" (list (cons 0 "*LINE,ARC")(cons 410 (getvar 'CTAB)))))
        (setvar 'NOMUTT mut) ss
      )
  (if (setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
    (progn
      (setq en	(ssname ss 0)
	    crv	(vlax-ename->vla-object en)
	    pt	(vlax-curve-getclosestpointto crv (trans pt 1 0))
	    ds	(vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv)))
      (cond ((= (vla-get-ObjectName crv) "AcDbLine")
	     (setq ds1 (distance (cdr(assoc 10 (entget en))) pt)))
	    ((or (= (vla-get-ObjectName crv) "AcDb3dPolyline")
                 (and
                     (= (vla-get-ObjectName crv) "AcDb2dPolyline")
                     (/= (logand (cdr(assoc 70 (entget en))) 2) 2) ;_Fit
                     (/= (logand (cdr(assoc 70 (entget en))) 4) 4) ;_Spline
                     (vl-every 'zerop (getblg en))
                     )
                 (and
                     (= (vla-get-ObjectName crv) "AcDbPolyline")
                     (vl-every 'zerop (getblg en))
                     )
                 )
	     (setq vx ((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam crv))
                       (setq lst (append lst (list (vlax-curve-getPointAtParam crv i))))) lst)))
	     (setq p1 (car vx) vx (cdr vx) ds1 0)
	     (while (and (setq p2 (car vx))
			 (not (equal (+ (distance Pt P1) (distance Pt P2)) (distance P1 P2) 0.00001))
			 )
	       (setq vx (cdr vx) ds1 (+ ds1 (distance P1 P2)) p1 p2)
	       )
	       (setq ds1 (+ ds1 (distance P1 Pt))))
	    (t (setq  ds1 (vlax-curve-getDistAtParam
			    crv (vlax-curve-getParamAtPoint crv pt)))))
      (dr_st (trans pt 0 1)
	     (angle (trans pt 0 1)
		    (trans (vlax-curve-getPointAtParam crv
			(+ (vlax-curve-getParamAtDist crv ds1) 0.0001))
		      0  1)) 1)
      (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
      (initget "Поменять Change _C C")
      (princ "\nДлинна объекта ")(princ ds1)
      (princ " [Поменять начало] <готово>:")(setq en (getkword))
      (if (= en "C")
	(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
	       (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
	       (setq ds1 (- ds ds1))
	)
      )
      (princ "\nВторая точка выноски :")
      (if (getvar "CMLEADERSTYLE")
       (draw-mleader
         pt ;_ начальная точка
         pause ;_запрос второй точкм
         (list
           (strcat "Имя слоя " (vla-get-layer crv)) ;_1-я строка
           (strcat "Длина " (rtos ds1 2 3))  ;_2-я строка длина до 3 знаков после запятой
           )
          1.5 ;_Вытота текста
          0.87 ;_Значение коэффициента см
;;; тему http://forum.dwg.ru/showpost.php?p=656758&postcount=51
         0.2 ;_отступ 1-го параграфа (форматтирование \\pxa)
         )
      (vl-cmdf "_LEADER"
	       (trans pt 0 1)
	       pause
	       ""
	       (rtos ds1 2 3)
	       "" )
        )
      )
    )
    )
  (setvar "OSMODE" osm)
  (vla-EndUndoMark adoc)
  (vl-cmdf "_redrawall")
  (princ))
  (defun draw-mleader (pt1 pt2 strlist Htxt koeff abz / dic mlst i)
  ;;; pt1 - начальная точка UCS
  ;;; pt2 - конечная точка UCS
  ;;; strlist - список строк
  ;;; Htxt - высота текста
  ;;; koeff - коэфф форматирования pxe или nil
  ;;; abz - коэфф форматирования абзаца \\pa или Nil
  ;;;(draw-mleader (setq pt1(getpoint))(getpoint pt1)(list "Пример" "Минскинжпроект" "Третья строка") 1.5 0.9 nil)
 ;;; Стиль мультивыноски текущий
  (setq i 0)
  (command
    "_mleader"
    "_h"
    "_none"
    pt1
    "_none"
    pt2
  (strcat (if koeff (strcat "\\px"
                              (if abz (strcat "a"(VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR abz))",") "")
                              "se" (VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR koeff))";") "")   ;;;"\\pxse0.87;"
;;;            "\\pa0.15;" (car strlist) "\\pa0;"
              (car strlist)
    )
    )
  (while (> (getvar "CMDACTIVE") 0) (command ""))
  (setq dic (vlax-ename->vla-object (entlast)))
  (vla-put-TextString dic
    (strcat (if koeff (strcat "\\px"
                              (if abz (strcat "a"(VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR abz))",") "")
                              "se" (VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR koeff))";") "")   ;;;"\\pxse0.87;"
;;;            "\\pa0.15;" (car strlist) "\\pa0;"
              (car strlist)
;;;              (if abz "\\pa0;" "")
            (apply 'strcat
                   (mapcar '(lambda (x) (strcat "\\P" (if (= (setq i (1+ i)) 1)(if abz "\\pa0;" "")   "")  x)) (cdr strlist))
            ) ;_ end of apply
    ) ;_ end of strcat
  )
    (vla-put-TextHeight dic Htxt)
    dic
  )
  (defun mip-conv-to-str (dat)
      (cond ((= (type dat) 'INT) (setq dat (itoa dat)))
            ((= (type dat) 'REAL) (setq dat (rtos dat 2 12)))
            ((null dat) (setq dat ""))
            (t (setq dat (vl-princ-to-string dat)))
      ) ;_ end of cond
    ) ;_ end of defun
(princ "\nНаберите в командной строке DSTS")
Другие варианты здесь (форум www.caduser.ru) Отмерить по линии расстояние и поставить точку, Прошу помощи у Вас!
__________________
Как использовать код на Лиспе читаем здесь

Последний раз редактировалось VVA, 19.09.2015 в 21:11. Причина: Добавлена ссылка
VVA вне форума  
 
Непрочитано 06.12.2010, 19:08
#12
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


VVA, а можно отдельно фрагмент этого кода, который просто спросит точку на кривой, а затем выдаст переменную со значением длины, чтоб я мог использовать этот фрагмент в своем коде #10? Плюс если можно, фрагмент, который даст мне переменную с именем слоя выбранной полилинии. Вообще, можно ли так смешивать командный метод с vl?

Странно....не смог найти переменную dsl

Последний раз редактировалось skkkk, 06.12.2010 в 19:14.
skkkk на форуме  
 
Непрочитано 06.12.2010, 19:21
2 | #13
VVA

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


Код:
[Выделить все]
(defun polydist (/ adoc *error* crvs eps dL pts pt1 pt2 ptc n osm vx p1 p2 ret)
  
;;;http://forum.dwg.ru/showthread.php?t=8713
;;; Ф-ция возвращает список вида  (расстояние_до_точки_полилинии имя_слоя) или nil
;;; Пример использования
;;;; (if (setq tmp (polydist))(alert (strcat "Длина полилинии до точки:\n" (rtos (car tmp) 2 3) "\nСлой : "(cadr tmp))))
  (defun *error* (msg)(princ msg)(vl-cmdf "_redrawall")(vla-EndUndoMark adoc)
    (setvar "OSMODE" osm))
  (defun dr_st (pt ang color / pt1 pt2)
    (setq pt1 (polar pt (+ ang 2.35619) (* 0.03 (getvar "VIEWSIZE"))))
    (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
    (grvecs (list color pt1 pt pt pt2)))
  (defun dr_kr (pt color / pt11 pt12 pt21 pt22 len)
    (setq len  (* 0.02 (getvar "VIEWSIZE"))
	  pt11 (polar pt 3.92699 len)
	  pt12 (polar pt 0.785398 len)
	  pt21 (polar pt 5.49779 len)
	  pt22 (polar pt 2.35619 len))
    (grvecs (list color pt11 pt12 pt21 pt22)))
(defun getblg ( pl / blglist i n ent_data tmp_ent)
(setq ent_data (entget pl))
(cond ((= (cdr(assoc 0 ent_data)) "LWPOLYLINE")
  (setq  blglist (mapcar 'cdr (vl-remove-if-not(function(lambda(x)(= 42(car x)))) ent_data))))
(t (setq tmp_ent pl)
 (while (/= "SEQEND"  (cdr(assoc 0 (entget(setq tmp_ent (entnext tmp_ent))))))
  (setq  blglist (append blglist (list (cdr(assoc 42 (entget tmp_ent)))))))))
   blglist)
  (vl-load-com)(setq osm (getvar "OSMODE"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark adoc)
  (setvar "CMDECHO" 0)(setvar "OSMODE" 512)
  (setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
  (if (setq ss (if pt
		 (ssget pt '((0 . "*LINE,ARC")))
		 nil)
      )
    (progn
      (setq en	(ssname ss 0)
	    crv	(vlax-ename->vla-object en)
	    pt	(vlax-curve-getclosestpointto crv (trans pt 1 0))
	    ds	(vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv)))
      (cond ((= (vla-get-ObjectName crv) "AcDbLine")
	     (setq ds1 (distance (cdr(assoc 10 (entget en))) pt)))
	    ((or (= (vla-get-ObjectName crv) "AcDb3dPolyline")
                 (and
                     (= (vla-get-ObjectName crv) "AcDb2dPolyline")
                     (/= (logand (cdr(assoc 70 (entget en))) 2) 2) ;_Fit
                     (/= (logand (cdr(assoc 70 (entget en))) 4) 4) ;_Spline
                     (vl-every 'zerop (getblg en))
                     )
                 (and
                     (= (vla-get-ObjectName crv) "AcDbPolyline")
                     (vl-every 'zerop (getblg en))
                     )
                 )
	     (setq vx ((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam crv))
                       (setq lst (append lst (list (vlax-curve-getPointAtParam crv i))))) lst)))
	     (setq p1 (car vx) vx (cdr vx) ds1 0)
	     (while (and (setq p2 (car vx))
			 (not (equal (+ (distance Pt P1) (distance Pt P2)) (distance P1 P2) 0.00001))
			 )
	       (setq vx (cdr vx) ds1 (+ ds1 (distance P1 P2)) p1 p2)
	       )
	       (setq ds1 (+ ds1 (distance P1 Pt))))
	    (t (setq  ds1 (vlax-curve-getDistAtParam
			    crv (vlax-curve-getParamAtPoint crv pt)))))
      (dr_st (trans pt 0 1)
	     (angle (trans pt 0 1)
		    (trans (vlax-curve-getPointAtParam crv
			(+ (vlax-curve-getParamAtDist crv ds1) 0.0001))
		      0  1)) 1)
      (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
      (initget "Поменять Change _C C")
      (princ "\nДлинна объекта ")(princ ds1)
      (princ " [Поменять начало] <готово>:")(setq en (getkword))
      (if (= en "C")
	(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
	       (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
	       (setq ds1 (- ds ds1))
	)
      )
      (setq ret (list ds1  (vla-get-layer crv)))
)
    )
  (vl-cmdf "_redrawall")
  ret
  )
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 06.12.2010, 20:31
#14
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


Спасибо, VVA, то, что надо. Осталось три вопроса(пока):
1) Как сделать разделителем в (rtos (car tmp) 2 3) запятую?
2) Как из названия слоя (cadr tmp) отсечь первые n символов?
Offtop: 3) Какая функция (если она есть) округляет число до целого меньшего
skkkk на форуме  
 
Непрочитано 06.12.2010, 23:14
1 | #15
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,589


1) (vl-string-subst "," "." (rtos (car tmp) 2 3))
2) substr
3) fix
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 09.12.2010, 12:47
#16
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


А возможно ли то же самое (#11), только в "двойном" виде, то есть если я выбираю точку пересечения (в частности, Т-образного) двух полилиний, и получаю две пары переменных:
Код:
[Выделить все]
(расстояние_до_точки_полилинии1 имя_слоя1)
(расстояние_до_точки_полилинии2 имя_слоя2)

Последний раз редактировалось skkkk, 15.12.2010 в 04:37.
skkkk на форуме  
 
Непрочитано 13.06.2012, 23:40
#17
DmAK


 
Регистрация: 28.10.2010
Сообщений: 15


День добрый, VVA! Можно Вас попросить изменить в коде DSTS (#11) вывод длины? 1) без имени слоя, 2)Формат вывода значения - Пикет: например число (длину) 1568,79 чтоб выводил в формате
ПК 15+68,79.
DmAK вне форума  
 
Непрочитано 16.06.2012, 13:56
#18
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


DmAK,
Цитата:
Сообщение от DmAK Посмотреть сообщение
в коде DSTS (#11)
надо найти строки
Код:
[Выделить все]
(list
           (strcat "Имя слоя " (vla-get-layer crv)) ;_1-я строка
           (strcat "Длина " (rtos ds1 2 3))  ;_2-я строка длина до 3 знаков после запятой
)
и заменить их на
Код:
[Выделить все]
(list
    (strcat "ПК" (rtos (atoi (rtos (/ ds1 100) 2 2)) 2 0) "+" (vl-string-subst "," "." (rtos (rem ds1 100) 2 2))) ;_1-я строка, длина до 2 знаков после запятой
)
skkkk на форуме  
 
Непрочитано 14.08.2014, 01:00
#19
AlGeMix


 
Регистрация: 14.08.2014
Сообщений: 4


Добрый день. Люди, прошу у вас помощи! Какие изменения надо внести в код DSTS, чтобы 1) выводимое значение было в 2 раза меньше (масштаб чертежа 1:500); 2) выводимое значение округлялось до 0.5?
AlGeMix вне форума  
 
Непрочитано 14.08.2014, 04:50
#20
trir


 
Регистрация: 18.12.2010
Сообщений: 3,371


В AutoCAD'е должен быть масштаб 1:1!
trir на форуме  
 
Непрочитано 14.08.2014, 09:31
#21
AlGeMix


 
Регистрация: 14.08.2014
Сообщений: 4


Это я понимаю. Но и все-таки. Я конечно в этом вопросе нуб, но нельзя ли в программу какое-нибудь "/ 2" добавить?
AlGeMix вне форума  
 
Непрочитано 14.08.2014, 10:51
#22
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


Цитата:
Сообщение от AlGeMix Посмотреть сообщение
нельзя ли в программу какое-нибудь "/ 2" добавить?
Можно. Нужно найти строку
Код:
[Выделить все]
(strcat "Длина " (rtos ds1 2 3))
и заменить на
Код:
[Выделить все]
(strcat "Длина " (rtos (/ ds1 2) 2 3))
Но все-таки, действительно чертить нужно в масштабе 1:1. Хотя бы просто потому, что помимо этой проблемы, где программно можно-таки решить, сразу решится много других. Например, при откладывании расстояний не нужно делить на 2, не будет путаницы с коэффициентами-масштабами и проч. Хотя и от специфики работы многое зависит, к примеру, есть чертежи, в которых масштаб по разным осям различен.
По поводу округления до 0.5 нужно уточнить. Оно должно произойти по правилам арифметики? Т.е. 1.2->1.0 (или просто 1); 1.3->1.5; 1.7->1.5; 1.8->2.0. Или в большую сторону? Или еще как-то?
skkkk на форуме  
 
Непрочитано 14.08.2014, 13:08
#23
AlGeMix


 
Регистрация: 14.08.2014
Сообщений: 4


skkkk, спасибо за быстрый ответ. Вы совершенно точно заметили насчет специфики работы. В моем случае она и есть. Округление до 0,5 в ближайшую сторону, как вы и написали. А что касается деления на 2, что заменить в варианте с пикетами из (#11)??
Код:
[Выделить все]
(list
    (strcat "ПК" (rtos (atoi (rtos (/ ds1 100) 2 2)) 2 0) "+" (vl-string-subst "," "." (rtos (rem ds1 100) 2 2))) ;_1-я строка, длина до 2 знаков после запятой
)
Пробовал сам придумать, но что-то оно ругается.
AlGeMix вне форума  
 
Непрочитано 14.08.2014, 13:35
#24
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


Цитата:
Сообщение от AlGeMix Посмотреть сообщение
Вы совершенно точно заметили насчет специфики работы. В моем случае она и есть.
Offtop: Это случайно не трасса какого-нибудь линейного объекта? С профилем? Дело в том, что я раньше тоже чертил в масштабе 1:2, но теперь признаю: это было моей самой большой ошибкой за все годы работы в Автокаде. Даже чертежи, приходящие от смежников в пятисотке, я теперь перевожу в тысячник (то есть, в масштаб 1:1 - в одном миллиметре один метр) Можно почитать тут.
По теме: нужно вместо ds1 написать (/ ds1 2). Но чтобы в случае, когда значение пикетажа соответствует самому пикету, не выдавалась надпись вида ПК3+0.0, надо строки из #23 заменить на:
Код:
[Выделить все]
(list
    (if (= (rem (/ ds1 2) 100) 0) 
        (strcat "ПК" (rtos (atoi (rtos (/ (/ ds1 2) 100) 2 10)) 2 0))
        (strcat "ПК" (rtos (atoi (rtos (/ (/ ds1 2) 100) 2 10)) 2 0) "+" (vl-string-subst "," "." (rtos (rem (/ ds1 2) 100) 2 1)))
    )
)
Проверить код сейчас нет возможности, поэтому мог ошибиться, но вроде все верно.
Насчет округления смогу посмотреть позже, когда - не знаю - большой завал.
skkkk на форуме  
 
Непрочитано 15.08.2014, 12:59
#25
AlGeMix


 
Регистрация: 14.08.2014
Сообщений: 4


Работает. Еще раз спасибо, очень выручили.

Offtop: Ага, трасса газопровода. Съемка изыскателей в 500-ом масштабе. Съемку мы не масштабируем, в каком масштабе пришла на той и чертим в модели, после выставляя в листах требуемый масштаб видового экрана.
AlGeMix вне форума  
 
Непрочитано 15.08.2014, 13:11
#26
sertor

Геодезист
 
Регистрация: 23.05.2012
Ухта
Сообщений: 1,340


Цитата:
Сообщение от AlGeMix Посмотреть сообщение
Съемка изыскателей в 500-ом масштабе. Съемку мы не масштабируем, в каком масштабе пришла на той и чертим в модели, после выставляя в листах требуемый масштаб видового экрана
Практически во всех геодезических программах экспорт в dxf/dwg по умолчанию выполняется в масштабе 1:1000 (пространство модели).
__________________
Как-то так.
sertor вне форума  
 
Непрочитано 23.12.2014, 12:44
#27
alex101000


 
Регистрация: 23.11.2011
Сообщений: 142


Уважаемые, может помочь в доработке ? Требуется получить общую длину сегментов между двумя точками на полилинии, не от начала. Между двумя указанными точками на полилинии может быть N узлов.
alex101000 вне форума  
 
Непрочитано 25.12.2014, 15:21
#28
alex101000


 
Регистрация: 23.11.2011
Сообщений: 142


Коряво, но работает:

Код:
[Выделить все]
 
(defun C:vert (/ ln1 ln2 lll)
	(setq ln1 (polydist))
	(setq ln2 (polydist))
	(if (< ln1 ln2) 
		(setq lll (- ln2 ln1)) 
		(setq lll (- ln1 ln2))
	)
      (strcat "Длина: " (vl-string-translate "." "," (rtos lll 2 4)))
)

(defun polydist (/ adoc *error* crvs eps dL pts pt1 pt2 ptc n osm vx p1 p2 ret)
  
;;;http://forum.dwg.ru/showthread.php?t=8713
;;; Ф-ция возвращает список вида  (расстояние_до_точки_полилинии имя_слоя) или nil
;;; Пример использования
;;;; (if (setq tmp (polydist))(alert (strcat "Длина полилинии до точки:\n" (rtos (car tmp) 2 3) "\nСлой : "(cadr tmp))))
  (defun *error* (msg)(princ msg)(vl-cmdf "_redrawall")(vla-EndUndoMark adoc)
    (setvar "OSMODE" osm))
  (defun dr_st (pt ang color / pt1 pt2)
    (setq pt1 (polar pt (+ ang 2.35619) (* 0.03 (getvar "VIEWSIZE"))))
    (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
    (grvecs (list color pt1 pt pt pt2)))
  (defun dr_kr (pt color / pt11 pt12 pt21 pt22 len)
    (setq len  (* 0.02 (getvar "VIEWSIZE"))
	  pt11 (polar pt 3.92699 len)
	  pt12 (polar pt 0.785398 len)
	  pt21 (polar pt 5.49779 len)
	  pt22 (polar pt 2.35619 len))
    (grvecs (list color pt11 pt12 pt21 pt22)))
(defun getblg ( pl / blglist i n ent_data tmp_ent)
(setq ent_data (entget pl))
(cond ((= (cdr(assoc 0 ent_data)) "LWPOLYLINE")
  (setq  blglist (mapcar 'cdr (vl-remove-if-not(function(lambda(x)(= 42(car x)))) ent_data))))
(t (setq tmp_ent pl)
 (while (/= "SEQEND"  (cdr(assoc 0 (entget(setq tmp_ent (entnext tmp_ent))))))
  (setq  blglist (append blglist (list (cdr(assoc 42 (entget tmp_ent)))))))))
   blglist)
  (vl-load-com)(setq osm (getvar "OSMODE"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark adoc)
;  (setvar "CMDECHO" 0)(setvar "OSMODE" 512)
  (setvar "CMDECHO" 0)(setvar "OSMODE" 33)
  (setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
  (if (setq ss (if pt
		 (ssget pt '((0 . "*LINE,ARC")))
		 nil)
      )
    (progn
      (setq en	(ssname ss 0)
	    crv	(vlax-ename->vla-object en)
	    pt	(vlax-curve-getclosestpointto crv (trans pt 1 0))
	    ds	(vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv)))
      (cond ((= (vla-get-ObjectName crv) "AcDbLine")
	     (setq ds1 (distance (cdr(assoc 10 (entget en))) pt)))
	    ((or (= (vla-get-ObjectName crv) "AcDb3dPolyline")
                 (and
                     (= (vla-get-ObjectName crv) "AcDb2dPolyline")
                     (/= (logand (cdr(assoc 70 (entget en))) 2) 2) ;_Fit
                     (/= (logand (cdr(assoc 70 (entget en))) 4) 4) ;_Spline
                     (vl-every 'zerop (getblg en))
                     )
                 (and
                     (= (vla-get-ObjectName crv) "AcDbPolyline")
                     (vl-every 'zerop (getblg en))
                     )
                 )
	     (setq vx ((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam crv))
                       (setq lst (append lst (list (vlax-curve-getPointAtParam crv i))))) lst)))
	     (setq p1 (car vx) vx (cdr vx) ds1 0)
	     (while (and (setq p2 (car vx))
			 (not (equal (+ (distance Pt P1) (distance Pt P2)) (distance P1 P2) 0.00001))
			 )
	       (setq vx (cdr vx) ds1 (+ ds1 (distance P1 P2)) p1 p2)
	       )
	       (setq ds1 (+ ds1 (distance P1 Pt))))
	    (t (setq  ds1 (vlax-curve-getDistAtParam
			    crv (vlax-curve-getParamAtPoint crv pt)))))
      (dr_st (trans pt 0 1)
	     (angle (trans pt 0 1)
		    (trans (vlax-curve-getPointAtParam crv
			(+ (vlax-curve-getParamAtDist crv ds1) 0.0001))
		      0  1)) 1)
      (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
      (initget "Поменять Change _C C")
      (princ "\nДлинна объекта ")(princ ds1)
      (princ " [Поменять начало] <готово>:")(setq en (getkword))
      (if (= en "C")
	(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
	       (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
	       (setq ds1 (- ds ds1))
	)
      )
;      (setq ret (list ds1  (vla-get-layer crv)))
;XL
;
      (setq ret ds1)
)
    )
  (vl-cmdf "_redrawall")
  ret
  )
alex101000 вне форума  
 
Непрочитано 25.12.2014, 15:34
#29
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,589


Зачем так сложно? Можно значительно быстрее и проще!
Код:
[Выделить все]
 (vl-load-com)

(defun tt (/ ent pt1 pt2)
  (if (and (= (type (setq ent (vl-catch-all-apply
                                (function
                                  (lambda ()
                                    (car (entsel "\nSelect Line, Spline or Polyline <Cancel> : "))
                                    ) ;_ end of lambda
                                  ) ;_ end of function
                                ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'ename
              ) ;_ end of =
           (wcmatch (strcase (cdr (assoc 0 (entget ent)))) "*LINE")
           (setq ent (vlax-ename->vla-object ent))
           (= (type (setq pt1 (vl-catch-all-apply
                                (function
                                  (lambda ()
                                    (getpoint "\nSelect first point <Cancel> : ")
                                    ) ;_ end of lambda
                                  ) ;_ end of function
                                ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'list
              ) ;_ end of =
           pt1
           (= (type (setq pt2 (vl-catch-all-apply
                                (function
                                  (lambda ()
                                    (getpoint "\nSelect second point <Cancel> : ")
                                    ) ;_ end of lambda
                                  ) ;_ end of function
                                ) ;_ end of vl-catch-all-apply
                          ) ;_ end of setq
                    ) ;_ end of type
              'list
              ) ;_ end of =
           pt2
           ) ;_ end of and
    (princ (strcat "\nDistance = "
                   (rtos (abs (- (vlax-curve-getdistatpoint ent (vlax-curve-getclosestpointto ent pt1))
                                 (vlax-curve-getdistatpoint ent (vlax-curve-getclosestpointto ent pt2))
                                 ) ;_ end of -
                              ) ;_ end of abs
                         2
                         (getvar "luprec")
                         ) ;_ end of rtos
                   ) ;_ end of strcat
           ) ;_ end of princ
    ) ;_ end of if
  (princ)
  ) ;_ end of defun
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 25.12.2014, 15:47
#30
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


Offtop: Эх, Алексей, где ж ты был пару дней назад?
Человек по ходу два дня сидел разбирался, осилил, понял где и что нужно поменять (хоть я код и не тестил, но уважение вызывает), а ты ему мол, можно проще и быстрее. За десять минут ему решение родил, вроде как когда уже и не надо.
alex101000, в жизни пригодится
skkkk на форуме  
 
Непрочитано 25.12.2014, 15:54
#31
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,589


skkkk, пару дней назад я занимался другой работой.
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 25.06.2019, 09:52
#32
Lumpy


 
Регистрация: 25.06.2019
Сообщений: 4


а возможно ли сделать так чтобы результат записывался в атрибут блока??
Lumpy вне форума  
 
Непрочитано 25.06.2019, 10:05
#33
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 6,629


Цитата:
Сообщение от Lumpy Посмотреть сообщение
а возможно ли сделать так чтобы результат записывался в атрибут блока??
Заменяете последний непустой вывод princ на присвоение значения переменной и потом значение этой переменной можете задавать любому выбранному объекту с поддержкой текста.
Сергей812 вне форума  
 
Непрочитано 25.06.2019, 17:09
#34
Lumpy


 
Регистрация: 25.06.2019
Сообщений: 4


Цитата:
Сообщение от Сергей812 Посмотреть сообщение
Заменяете последний непустой вывод princ на присвоение значения переменной и потом значение этой переменной можете задавать любому выбранному объекту с поддержкой текста.
спасибо.
а если не сложно предоставить пример функции присвоения значения перемеренной выбранному объекту.
Lumpy вне форума  
 
Непрочитано 26.06.2019, 17:57
#35
Lumpy


 
Регистрация: 25.06.2019
Сообщений: 4


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

Код:
[Выделить все]
  (defun C:DST (/ adoc *error* crvs eps dL pts pt1 pt2 ptc n osm vx p1 p2)
;;;http://forum.dwg.ru/showthread.php?p=113702#post113702 
  (defun *error* (msg)(princ msg)(vl-cmdf "_redrawall")(vla-EndUndoMark adoc)
    (setvar "OSMODE" osm))
  (defun dr_st (pt ang color / pt1 pt2)
    (setq pt1 (polar pt (+ ang 2.35619) (* 0.03 (getvar "VIEWSIZE"))))
    (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
    (grvecs (list color pt1 pt pt pt2)))
  (defun dr_kr (pt color / pt11 pt12 pt21 pt22 len)
    (setq len  (* 0.02 (getvar "VIEWSIZE"))
	  pt11 (polar pt 3.92699 len)
	  pt12 (polar pt 0.785398 len)
	  pt21 (polar pt 5.49779 len)
	  pt22 (polar pt 2.35619 len))
    (grvecs (list color pt11 pt12 pt21 pt22)))
(defun getblg ( pl / blglist i n ent_data tmp_ent)
(setq ent_data (entget pl))
(cond ((= (cdr(assoc 0 ent_data)) "LWPOLYLINE")
  (setq  blglist (mapcar 'cdr (vl-remove-if-not(function(lambda(x)(= 42(car x)))) ent_data))))
(t (setq tmp_ent pl)
 (while (/= "SEQEND"  (cdr(assoc 0 (entget(setq tmp_ent (entnext tmp_ent))))))
  (setq  blglist (append blglist (list (cdr(assoc 42 (entget tmp_ent)))))))))
   blglist)
  (vl-load-com)(setq osm (getvar "OSMODE"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark adoc)
  (setvar "CMDECHO" 0)(setvar "OSMODE" 512)
  (setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
  (if (setq ss (if pt
		 (ssget pt '((0 . "*LINE,ARC")))
		 nil)
      )
    (progn
      (setq en	(ssname ss 0)
	    crv	(vlax-ename->vla-object en)
	    pt	(vlax-curve-getclosestpointto crv (trans pt 1 0))
	    ds	(vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv)))
      (cond ((= (vla-get-ObjectName crv) "AcDbLine")
	     (setq ds1 (distance (cdr(assoc 10 (entget en))) pt)))
	    ((or (= (vla-get-ObjectName crv) "AcDb3dPolyline")
                 (and
                     (= (vla-get-ObjectName crv) "AcDb2dPolyline")
                     (/= (logand (cdr(assoc 70 (entget en))) 2) 2) ;_Fit
                     (/= (logand (cdr(assoc 70 (entget en))) 4) 4) ;_Spline
                     (vl-every 'zerop (getblg en))
                     )
                 (and
                     (= (vla-get-ObjectName crv) "AcDbPolyline")
                     (vl-every 'zerop (getblg en))
                     )
                 )
	     (setq vx ((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam crv))
                       (setq lst (append lst (list (vlax-curve-getPointAtParam crv i))))) lst)))
	     (setq p1 (car vx) vx (cdr vx) ds1 0)
	     (while (and (setq p2 (car vx))
			 (not (equal (+ (distance Pt P1) (distance Pt P2)) (distance P1 P2) 0.00001))
			 )
	       (setq vx (cdr vx) ds1 (+ ds1 (distance P1 P2)) p1 p2)
	       )
	       (setq ds1 (+ ds1 (distance P1 Pt))))
	    (t (setq  ds1 (vlax-curve-getDistAtParam
			    crv (vlax-curve-getParamAtPoint crv pt)))))
      (dr_st (trans pt 0 1)
	     (angle (trans pt 0 1)
		    (trans (vlax-curve-getPointAtParam crv
			(+ (vlax-curve-getParamAtDist crv ds1) 0.0001))
		      0  1)) 1)
      (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
      (initget "Поменять Change _C C")
      (princ "\nДлинна объекта ")(princ ds1)
      (princ " [Поменять начало] <готово>:")(setq en (getkword))
      (if (= en "C")
	(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
	       (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
	       (setq ds1 (- ds ds1))
	)
      )
      (princ "\nВторая точка выноски :")
      (if (getvar "CMLEADERSTYLE")
       (draw-mleader
         pt ;_ начальная точка
         pause ;_запрос второй точкм
         (list
           (if (= (rem ds1 1000) 0) 
        (strcat "КМ" (rtos (atoi (rtos (/ ds1 1000) 2 10)) 2 0))
        (strcat "КМ" (rtos (atoi (rtos (/ ds1 1000) 2 10)) 2 0) "+" (vl-string-subst "," "." (rtos (rem ds1 1000) 2 1)))
    )
           )
          1.5 ;_Вытота текста
          0.87 ;_Значение коэффициента см
;;; тему http://forum.dwg.ru/showpost.php?p=656758&postcount=51
         0.2 ;_отступ 1-го параграфа (форматтирование \\pxa)
         )
      (vl-cmdf "_LEADER"
	       (trans pt 0 1)
	       pause
	       ""
	       (rtos ds1 2 3)
	       "" )
        )
      )
    )
  (setvar "OSMODE" osm)
  (vla-EndUndoMark adoc)
  (vl-cmdf "_redrawall")
  (princ))
  (defun draw-mleader (pt1 pt2 strlist Htxt koeff abz / dic mlst i)
  ;;; pt1 - начальная точка UCS
  ;;; pt2 - конечная точка UCS
  ;;; strlist - список строк
  ;;; Htxt - высота текста
  ;;; koeff - коэфф форматирования pxe или nil
  ;;; abz - коэфф форматирования абзаца \\pa или Nil
  ;;;(draw-mleader (setq pt1(getpoint))(getpoint pt1)(list "Пример" "Минскинжпроект" "Третья строка") 1.5 0.9 nil)
 ;;; Стиль мультивыноски текущий
  (setq i 0)
  (command
    "_mleader"
    "_h"
    "_none"
    pt1
    "_none"
    pt2
  (strcat (if koeff (strcat "\\px"
                              (if abz (strcat "a"(VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR abz))",") "")
                              "se" (VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR koeff))";") "")   ;;;"\\pxse0.87;"
;;;            "\\pa0.15;" (car strlist) "\\pa0;"
              (car strlist)
    )
    )
  (while (> (getvar "CMDACTIVE") 0) (command ""))
  (setq dic (vlax-ename->vla-object (entlast)))
  (vla-put-TextString dic
    (strcat (if koeff (strcat "\\px"
                              (if abz (strcat "a"(VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR abz))",") "")
                              "se" (VL-STRING-RIGHT-TRIM "0" (MIP-CONV-TO-STR koeff))";") "")   ;;;"\\pxse0.87;"
;;;            "\\pa0.15;" (car strlist) "\\pa0;"
              (car strlist)
;;;              (if abz "\\pa0;" "")
            (apply 'strcat
                   (mapcar '(lambda (x) (strcat "\\P" (if (= (setq i (1+ i)) 1)(if abz "\\pa0;" "")   "")  x)) (cdr strlist))
            ) ;_ end of apply
    ) ;_ end of strcat
  )
    (vla-put-TextHeight dic Htxt)
    dic
  )
  (defun mip-conv-to-str (dat)
      (cond ((= (type dat) 'INT) (setq dat (itoa dat)))
            ((= (type dat) 'REAL) (setq dat (rtos dat 2 12)))
            ((null dat) (setq dat ""))
            (t (setq dat (vl-princ-to-string dat)))
      ) ;_ end of cond
    ) ;_ end of defun
(princ "\nНаберите в командной строке DST")
Lumpy вне форума  
 
Непрочитано 06.07.2019, 08:48
#36
skkkk

AutoCAD_2008->2011
 
Регистрация: 20.03.2008
Московская область
Сообщений: 2,260


Lumpy, для проектировщика ТЗ могло бы быть более обширным.
Если всё правильно понял, то вот (без проверки на пустой клик, т.е, если попасть куда-либо мимо атрибута, то будут ошибки). Но поскольку ТЗ - хз, то и обработчик ошибок еще рановато делать. Да, и атрибут при этом должен быть многострочным, иначе, результат не очень порадует. Разумеется, как готовая программа использоваться не может. Прототип, типа.

Код:
[Выделить все]
   (defun C:DST2ATR (/ adoc *error* crvs eps dL pts pt1 pt2 ptc n osm vx p1 p2 str attr)
;;;http://forum.dwg.ru/showthread.php?p=113702#post113702 
  (defun *error* (msg)(princ msg)(vl-cmdf "_redrawall")(vla-EndUndoMark adoc)
    (setvar "OSMODE" osm))
  (defun dr_st (pt ang color / pt1 pt2)
    (setq pt1 (polar pt (+ ang 2.35619) (* 0.03 (getvar "VIEWSIZE"))))
    (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
    (grvecs (list color pt1 pt pt pt2)))
  (defun dr_kr (pt color / pt11 pt12 pt21 pt22 len)
    (setq len  (* 0.02 (getvar "VIEWSIZE"))
	  pt11 (polar pt 3.92699 len)
	  pt12 (polar pt 0.785398 len)
	  pt21 (polar pt 5.49779 len)
	  pt22 (polar pt 2.35619 len))
    (grvecs (list color pt11 pt12 pt21 pt22)))
(defun getblg ( pl / blglist i n ent_data tmp_ent)
(setq ent_data (entget pl))
(cond ((= (cdr(assoc 0 ent_data)) "LWPOLYLINE")
  (setq  blglist (mapcar 'cdr (vl-remove-if-not(function(lambda(x)(= 42(car x)))) ent_data))))
(t (setq tmp_ent pl)
 (while (/= "SEQEND"  (cdr(assoc 0 (entget(setq tmp_ent (entnext tmp_ent))))))
  (setq  blglist (append blglist (list (cdr(assoc 42 (entget tmp_ent)))))))))
   blglist)
  (vl-load-com)(setq osm (getvar "OSMODE"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark adoc)
  (setvar "CMDECHO" 0)(setvar "OSMODE" 512)
  (setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
  (if (setq ss (if pt
		 (ssget pt '((0 . "*LINE,ARC")))
		 nil)
      )
    (progn
      (setq en	(ssname ss 0)
	    crv	(vlax-ename->vla-object en)
	    pt	(vlax-curve-getclosestpointto crv (trans pt 1 0))
	    ds	(vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv)))
      (cond ((= (vla-get-ObjectName crv) "AcDbLine")
	     (setq ds1 (distance (cdr(assoc 10 (entget en))) pt)))
	    ((or (= (vla-get-ObjectName crv) "AcDb3dPolyline")
                 (and
                     (= (vla-get-ObjectName crv) "AcDb2dPolyline")
                     (/= (logand (cdr(assoc 70 (entget en))) 2) 2) ;_Fit
                     (/= (logand (cdr(assoc 70 (entget en))) 4) 4) ;_Spline
                     (vl-every 'zerop (getblg en))
                     )
                 (and
                     (= (vla-get-ObjectName crv) "AcDbPolyline")
                     (vl-every 'zerop (getblg en))
                     )
                 )
	     (setq vx ((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam crv))
                       (setq lst (append lst (list (vlax-curve-getPointAtParam crv i))))) lst)))
	     (setq p1 (car vx) vx (cdr vx) ds1 0)
	     (while (and (setq p2 (car vx))
			 (not (equal (+ (distance Pt P1) (distance Pt P2)) (distance P1 P2) 0.00001))
			 )
	       (setq vx (cdr vx) ds1 (+ ds1 (distance P1 P2)) p1 p2)
	       )
	       (setq ds1 (+ ds1 (distance P1 Pt))))
	    (t (setq  ds1 (vlax-curve-getDistAtParam
			    crv (vlax-curve-getParamAtPoint crv pt)))))
      (dr_st (trans pt 0 1)
	     (angle (trans pt 0 1)
		    (trans (vlax-curve-getPointAtParam crv
			(+ (vlax-curve-getParamAtDist crv ds1) 0.0001))
		      0  1)) 1)
      (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
      (initget "Поменять Change _C C")
      (princ "\nДлинна объекта ")(princ ds1)
      (princ " [Поменять начало] <готово>:")(setq en (getkword))
      (if (= en "C")
		(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
			   (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
			   (setq ds1 (- ds ds1))
		)
      )
      )
    )
	(setq str 
		(strcat 
			"КМ" (rtos (atoi (rtos (/ ds1 1000) 2 10)) 2 0) "\n"
			"КМ" (rtos (atoi (rtos (/ ds1 1000) 2 10)) 2 0) "+" (vl-string-subst "," "." (rtos (rem ds1 1000) 2 1))
		)
	)
	(setq attr (car (nentsel "\nВыберите атрибут блока: ")))
	(if  attr
		(vla-put-TextString (vlax-ename->vla-object attr) str)
	
	
	
	)
  (setvar "OSMODE" osm)
  (vla-EndUndoMark adoc)
  (vl-cmdf "_redrawall")
  (princ))
	(princ "\nНаберите в командной строке DST2ATR")(princ)

Последний раз редактировалось skkkk, 07.07.2019 в 01:25.
skkkk на форуме  
 
Непрочитано 08.07.2019, 09:18
#37
Lumpy


 
Регистрация: 25.06.2019
Сообщений: 4


Цитата:
Сообщение от skkkk Посмотреть сообщение
Lumpy, для проектировщика ТЗ могло бы быть более обширным.
Если всё правильно понял, то вот (без проверки на пустой клик, т.е, если попасть куда-либо мимо атрибута, то будут ошибки). Но поскольку ТЗ - хз, то и обработчик ошибок еще рановато делать. Да, и атрибут при этом должен быть многострочным, иначе, результат не очень порадует. Разумеется, как готовая программа использоваться не может. Прототип, типа.

Код:
[Выделить все]
   (defun C:DST2ATR (/ adoc *error* crvs eps dL pts pt1 pt2 ptc n osm vx p1 p2 str attr)
;;;http://forum.dwg.ru/showthread.php?p=113702#post113702 
  (defun *error* (msg)(princ msg)(vl-cmdf "_redrawall")(vla-EndUndoMark adoc)
    (setvar "OSMODE" osm))
  (defun dr_st (pt ang color / pt1 pt2)
    (setq pt1 (polar pt (+ ang 2.35619) (* 0.03 (getvar "VIEWSIZE"))))
    (setq pt2 (polar pt (+ ang 3.92699) (* 0.03 (getvar "VIEWSIZE"))))
    (grvecs (list color pt1 pt pt pt2)))
  (defun dr_kr (pt color / pt11 pt12 pt21 pt22 len)
    (setq len  (* 0.02 (getvar "VIEWSIZE"))
	  pt11 (polar pt 3.92699 len)
	  pt12 (polar pt 0.785398 len)
	  pt21 (polar pt 5.49779 len)
	  pt22 (polar pt 2.35619 len))
    (grvecs (list color pt11 pt12 pt21 pt22)))
(defun getblg ( pl / blglist i n ent_data tmp_ent)
(setq ent_data (entget pl))
(cond ((= (cdr(assoc 0 ent_data)) "LWPOLYLINE")
  (setq  blglist (mapcar 'cdr (vl-remove-if-not(function(lambda(x)(= 42(car x)))) ent_data))))
(t (setq tmp_ent pl)
 (while (/= "SEQEND"  (cdr(assoc 0 (entget(setq tmp_ent (entnext tmp_ent))))))
  (setq  blglist (append blglist (list (cdr(assoc 42 (entget tmp_ent)))))))))
   blglist)
  (vl-load-com)(setq osm (getvar "OSMODE"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-StartUndoMark adoc)
  (setvar "CMDECHO" 0)(setvar "OSMODE" 512)
  (setq pt (getpoint "\nУкажите точку на кривой <выход> : "))
  (if (setq ss (if pt
		 (ssget pt '((0 . "*LINE,ARC")))
		 nil)
      )
    (progn
      (setq en	(ssname ss 0)
	    crv	(vlax-ename->vla-object en)
	    pt	(vlax-curve-getclosestpointto crv (trans pt 1 0))
	    ds	(vlax-curve-getDistAtParam crv (vlax-curve-getEndParam crv)))
      (cond ((= (vla-get-ObjectName crv) "AcDbLine")
	     (setq ds1 (distance (cdr(assoc 10 (entget en))) pt)))
	    ((or (= (vla-get-ObjectName crv) "AcDb3dPolyline")
                 (and
                     (= (vla-get-ObjectName crv) "AcDb2dPolyline")
                     (/= (logand (cdr(assoc 70 (entget en))) 2) 2) ;_Fit
                     (/= (logand (cdr(assoc 70 (entget en))) 4) 4) ;_Spline
                     (vl-every 'zerop (getblg en))
                     )
                 (and
                     (= (vla-get-ObjectName crv) "AcDbPolyline")
                     (vl-every 'zerop (getblg en))
                     )
                 )
	     (setq vx ((lambda ( / i lst)(while (<= (setq i (if i (1+ i) 0))(vlax-curve-getEndParam crv))
                       (setq lst (append lst (list (vlax-curve-getPointAtParam crv i))))) lst)))
	     (setq p1 (car vx) vx (cdr vx) ds1 0)
	     (while (and (setq p2 (car vx))
			 (not (equal (+ (distance Pt P1) (distance Pt P2)) (distance P1 P2) 0.00001))
			 )
	       (setq vx (cdr vx) ds1 (+ ds1 (distance P1 P2)) p1 p2)
	       )
	       (setq ds1 (+ ds1 (distance P1 Pt))))
	    (t (setq  ds1 (vlax-curve-getDistAtParam
			    crv (vlax-curve-getParamAtPoint crv pt)))))
      (dr_st (trans pt 0 1)
	     (angle (trans pt 0 1)
		    (trans (vlax-curve-getPointAtParam crv
			(+ (vlax-curve-getParamAtDist crv ds1) 0.0001))
		      0  1)) 1)
      (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 1)
      (initget "Поменять Change _C C")
      (princ "\nДлинна объекта ")(princ ds1)
      (princ " [Поменять начало] <готово>:")(setq en (getkword))
      (if (= en "C")
		(progn (dr_kr (trans (vlax-curve-getStartPoint crv) 0 1) 0)
			   (dr_kr (trans (vlax-curve-getEndPoint crv) 0 1) 1)
			   (setq ds1 (- ds ds1))
		)
      )
      )
    )
	(setq str 
		(strcat 
			"КМ" (rtos (atoi (rtos (/ ds1 1000) 2 10)) 2 0) "\n"
			"КМ" (rtos (atoi (rtos (/ ds1 1000) 2 10)) 2 0) "+" (vl-string-subst "," "." (rtos (rem ds1 1000) 2 1))
		)
	)
	(setq attr (car (nentsel "\nВыберите атрибут блока: ")))
	(if  attr
		(vla-put-TextString (vlax-ename->vla-object attr) str)
	
	
	
	)
  (setvar "OSMODE" osm)
  (vla-EndUndoMark adoc)
  (vl-cmdf "_redrawall")
  (princ))
	(princ "\nНаберите в командной строке DST2ATR")(princ)
Огромнейшее спасибо все работает как нужно.
Lumpy вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > AutoCAD > Расстояние от начала полилинии до опеделенной точки

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск