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

| Правила | Регистрация | Пользователи | Сообщения за день |

Поиск |

Справка по форуму | Файлообменник |

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

Ответ

Перейти к новому

Перейти к новому

Поиск в этой теме

20.10.2006, 15:53		#1
Расстояние от начала полилинии до опеделенной точки bimari проектирование дорог Riga Регистрация: 18.10.2006 Сообщений: 25 Подскажите, пожалуйста как в 2006 акаде можно было определить расстояние от начала полилинии до любой ее точки. Было бы хорошо, если бы кликнув на эту точку появлялся Leader с расстоянием. Заранее спасибо!
Просмотров: 19563

Непрочитано

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,996

Пробуй

Код:

[Выделить все]

(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,627

Интересно, Лентяй покороче сможет написать?

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,996

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

VVA вне форума

Непрочитано

19.01.2007, 15:39

#9

VVA

Инженер LISP

Регистрация: 11.05.2005

Минск

Сообщений: 6,996

Сбоила 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

Регистрация: 20.03.2008

Сообщений: 2,680

Не смог разобраться, какая переменная из #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,996

Цитата:

Сообщение от 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

Регистрация: 20.03.2008

Сообщений: 2,680

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

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

Последний раз редактировалось skkkk, 06.12.2010 в 19:14.

skkkk вне форума

Непрочитано

06.12.2010, 19:21

2 |

#13

VVA

Инженер LISP

Регистрация: 11.05.2005

Минск

Сообщений: 6,996

Код:

[Выделить все]

(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

Регистрация: 20.03.2008

Сообщений: 2,680

Спасибо, 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

С.-Петербург

Сообщений: 40,402

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

__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.

Кулик Алексей aka kpblc вне форума

Непрочитано

09.12.2010, 12:47

#16

skkkk

Регистрация: 20.03.2008

Сообщений: 2,680

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

Код:

[Выделить все]

(расстояние_до_точки_полилинии1 имя_слоя1)
(расстояние_до_точки_полилинии2 имя_слоя2)

Последний раз редактировалось skkkk, 15.12.2010 в 04:37.

skkkk вне форума

Непрочитано

13.06.2012, 23:40

#17

DmAK

Регистрация: 28.10.2010

Сообщений: 21

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

DmAK вне форума

Непрочитано

16.06.2012, 13:56

#18

skkkk

Регистрация: 20.03.2008

Сообщений: 2,680

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

| 1

#20

trir

Регистрация: 18.12.2010

Сообщений: 5,107

В AutoCAD'е должен быть масштаб 1:1!

trir вне форума

Непрочитано

14.08.2014, 09:31

#21

AlGeMix

Регистрация: 14.08.2014

Сообщений: 4

Это я понимаю. Но и все-таки. Я конечно в этом вопросе нуб, но нельзя ли в программу какое-нибудь "/ 2" добавить?

AlGeMix вне форума

Непрочитано

14.08.2014, 10:51

#22

skkkk

Регистрация: 20.03.2008

Сообщений: 2,680

Цитата:

Сообщение от 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

Регистрация: 20.03.2008

Сообщений: 2,680

Цитата:

Сообщение от 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,377

Цитата:

Сообщение от AlGeMix

Посмотреть сообщение

Съемка изыскателей в 500-ом масштабе. Съемку мы не масштабируем, в каком масштабе пришла на той и чертим в модели, после выставляя в листах требуемый масштаб видового экрана

Практически во всех геодезических программах экспорт в dxf/dwg по умолчанию выполняется в масштабе 1:1000 (пространство модели).

__________________
Как-то так.

sertor вне форума

Непрочитано

23.12.2014, 12:44

#27

alex101000

Регистрация: 23.11.2011

Сообщений: 176

Уважаемые, может помочь в доработке ? Требуется получить общую длину сегментов между двумя точками на полилинии, не от начала. Между двумя указанными точками на полилинии может быть N узлов.

alex101000 вне форума

Непрочитано

25.12.2014, 15:21

#28

alex101000

Регистрация: 23.11.2011

Сообщений: 176

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

Код:

[Выделить все]

 
(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

С.-Петербург

Сообщений: 40,402

Зачем так сложно? Можно значительно быстрее и проще!

Код:

[Выделить все]

 (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

__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.

Кулик Алексей aka kpblc вне форума

Непрочитано

25.12.2014, 15:47

#30

skkkk

Регистрация: 20.03.2008

Сообщений: 2,680

Offtop: Эх, Алексей, где ж ты был пару дней назад?

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

alex101000, в жизни пригодится

skkkk вне форума

Непрочитано

25.12.2014, 15:54

#31

Кулик Алексей aka kpblc

Moderator

LISP, C# (ACAD 200[9,12,13,14])

Регистрация: 25.08.2003

С.-Петербург

Сообщений: 40,402

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

__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.

Кулик Алексей aka kpblc вне форума

Непрочитано

25.06.2019, 09:52

#32

Lumpy

Регистрация: 25.06.2019

Сообщений: 13

а возможно ли сделать так чтобы результат записывался в атрибут блока??

Lumpy вне форума

Непрочитано

25.06.2019, 10:05

#33

Сергей812

Регистрация: 10.08.2013

Сообщений: 11,499

Цитата:

Сообщение от Lumpy

Посмотреть сообщение

а возможно ли сделать так чтобы результат записывался в атрибут блока??

Заменяете последний непустой вывод princ на присвоение значения переменной и потом значение этой переменной можете задавать любому выбранному объекту с поддержкой текста.

Сергей812 вне форума

Непрочитано

25.06.2019, 17:09

#34

Lumpy

Регистрация: 25.06.2019

Сообщений: 13

Цитата:

Сообщение от Сергей812

Посмотреть сообщение

Заменяете последний непустой вывод princ на присвоение значения переменной и потом значение этой переменной можете задавать любому выбранному объекту с поддержкой текста.

спасибо.
а если не сложно предоставить пример функции присвоения значения перемеренной выбранному объекту.

Lumpy вне форума

Непрочитано

26.06.2019, 17:57

#35

Lumpy

Регистрация: 25.06.2019

Сообщений: 13

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

Код:

[Выделить все]

  (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

Регистрация: 20.03.2008

Сообщений: 2,680

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

Сообщений: 13

Цитата:

Сообщение от 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 вне форума

Непрочитано

15.11.2020, 14:15

#38

Blik91

Регистрация: 15.11.2020

Сообщений: 5

Цитата:

Сообщение от Lumpy

Посмотреть сообщение

Огромнейшее спасибо все работает как нужно.

Поделитесь окончательным вариантом лиспа?
Попробовал запустить, пишет:
Рекомендуется преобразовать (command) в (command-s)

Нашел, что ошибка из-за кода для версий до 2015 года. Может у вас есть для современных версий?

Blik91 вне форума

Непрочитано

15.11.2020, 19:45

#39

skkkk

Регистрация: 20.03.2008

Сообщений: 2,680

Blik91, о каком лиспе речь?

skkkk вне форума

Непрочитано

15.11.2020, 20:28

#40

Blik91

Регистрация: 15.11.2020

Сообщений: 5

Цитата:

Сообщение от skkkk

Посмотреть сообщение

Blik91, о каком лиспе речь?

Предыдущий пост #37.

Blik91 вне форума

Непрочитано

18.11.2020, 01:37

#41

Barmaley Bubusikin

Регистрация: 05.06.2014

Сообщений: 77

Цитата:

Сообщение от skkkk

Посмотреть сообщение

Blik91, о каком лиспе речь?

Код из #37. Если не выбрать атрибут, то:

Цитата:

Выберите атрибут блока: *Прервано*
Функция прервана.
Невозможно вызвать (command) из *error* без предварительного вызова (*push-error-using-command*).
Рекомендуется преобразовать (command) в (command-s)

А что такое "КМ0КМ0" перед длиной?

Barmaley Bubusikin вне форума

Непрочитано

24.03.2021, 16:42

#42

Lumpy

Регистрация: 25.06.2019

Сообщений: 13

Цитата:

Сообщение от 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)

Добрый день.
В продолжение данной темы возник вопрос.
Возможно ли как-нибудь соединить 2 кода в один.

Код:

[Выделить все]

 (defun C:SELPOLY ()
  ;;; Выделение объектов, пересекаемых полилинией
  (selpoly nil)
  (princ)
  )
(defun C:BSELPOLY ()
  ;;; Выделение блоков, пересекаемых полилинией
  (selpoly (list(cons 0 "INSERT")))
  (princ)
  )
(defun block-get-name (blkobj)
(cond
  ((and (vlax-property-available-p blkobj 'isdynamicblock)
	(= (vla-get-isdynamicblock blkobj) :vlax-true)
	) ;_ end of and
   (vla-get-effectivename blkobj)
   )
  (t (vla-get-name blkobj))
  ) ;_ end of cond
  )
;| ! *******************************************************************
;; !                  _IsPtInView
;; ! *******************************************************************
;; ! Проверяет находится ли точка в видовом экране
;; ! Auguments: 'pt'  - Точка для анализа в МСК!!!
;; ! Return   : T или nil если 'pt' в видовом экране или нет
;; ! *******************************************************************|;
(defun _get-viewctr-size ( / VCTR Y_Len SSZ X_Pix Y_Pix X_Len)
  (setq VCTR (getvar "VIEWCTR") Y_Len (getvar "VIEWSIZE")
   SSZ (getvar "SCREENSIZE")
   X_Pix (car SSZ) Y_Pix (cadr SSZ)
   X_Len (* (/ X_Pix Y_Pix) Y_Len)
        )
   (list(mapcar '- VCTR (list (* 0.5 X_len)(* 0.5 Y_len)))
        (mapcar '+ VCTR (list (* 0.5 X_len)(* 0.5 Y_len)))
        )
  )
(defun _IsPtInView (pt / Lc Uc)
(setq pt (trans pt 0 1))
(setq Lc (_get-viewctr-size)
      Uc (cadr Lc)
      Lc (car Lc)
      )
  (if (and (> (car pt) (car Lc))(< (car pt) (car Uc))
	 (> (cadr pt) (cadr Lc))(< (cadr pt) (cadr Uc))
         )
	T nil))
;| ! ***************************************************************************
;; !           _pt_extents
;; ! ***************************************************************************
;; ! Function : Возвращает границы MIN, MAX X,Y,Z списка точек
;; ! Argument : 'vlist' - Список точек
;; ! Returns  : Список точек (ЛевНижн ПравВерхн)
;; ! ***************************************************************************|;
(defun  _pt_extents (vlist / tmp)
  (setq tmp (apply 'mapcar (cons 'list vlist)))
  (list (mapcar '(lambda(x)(apply 'min x)) tmp)(mapcar '(lambda(x)(apply 'max x)) tmp)));_defun
  ;; !                             _Zoom2Lst
;; ! **********************************************************
;; ! Function : Zoom границ списка точек
;; ! Arguments: 'vlist' - Список точек в МСК!!!!
;; ! Зуммирует экран, чтобы все точки были видны
;; ! Returns  : t - было зуммирование nil - нет
;; ! **********************************************************
  (defun _Zoom2Lst (vlist / pts)
    (setq pts (_pt_extents (mip:ZZero vlist)))
    (if (not (and (_IsPtInView (car pts)) (_IsPtInView (cadr pts))))
      (progn
        (vla-ZoomWindow (vlax-get-acad-object)(vlax-3d-point (car pts))(vlax-3d-point (cadr pts)))
	(vlax-invoke (vlax-get-acad-object) 'ZoomScaled 0.85 acZoomScaledRelative)
	T
	)
      nil
      )
  ) ;end
(defun mip:entsel (promt filter entlist / key n newentlist ent_point promt)
;;;Функция mip:entsel
;;;Еденичный выбор объекта, замена функции entsel
;;;Возвращает entity name выбранного примитива или nil, точку указания запоминает в переменной LASTPOINT
;;;Параметры:
;;;promt - предложение выбрать объект (string)
;;;filter - фильтр объектов для выбора вида '("LINE" "LWPOLYLINE")
;;;entlist - список примитивов которые не надо выбирать (либо список entity name, либо PICKSET)
;;;
;;;Примеры:
;;;(mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") nil)
;;;(mip:entsel "\nВыберите объекты" nil nil)
;;;(setq aa nil) (mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") (while (setq a (car (entsel))) (setq aa (append aa (list a)))))
;;;(mip:entsel "\nВыберите объекты" '("LINE" "LWPOLYLINE") (ssget))
  (setq key T n 0 newentlist nil)
  (if (eq (type entlist) 'PICKSET)
    (progn
    	(while (setq a (ssname entlist n)) (setq newentlist (append newentlist (list a)) n (1+ n)))
    	(setq entlist newentlist)
    );progn
   );if
    (while key
    	(if (or (setq ent_point (entsel promt)) (= (getvar "ERRNO") 7))
	  	(if (or (eq (type ent_point) 'LIST) (not ent_point))
		  (if ent_point
		    (if (member (setq ent (car ent_point)) entlist)
		      (princ "\nПримитив уже выбран")
		      (if filter
			      (if (not (member (cdr (assoc 0 (entget ent))) filter))
				(progn (setq str "\nНе верный выбор, выберите: ")
				  (princ (substr (setq str (foreach n filter (setq str (strcat str n ", ")))) 1 (- (strlen str) 2)))
				);progn
				(setq key nil)
			      );if
				(setq key nil)
			);if
		    );if
		    (setq key T)
		  );if
	    	(setq key nil)
	    );if
	  (setq key nil)
      	);if
     );while
  (if (eq (type ent_point) 'LIST)
    (progn (setvar "LASTPOINT" (cadr ent_point)) ent)
    ent_point
  );if
);defun
  (defun mip_MakeUniqueMembersOfList  ( lst / OutList head)
;;;Удаляет одинаковые (дубликаты) элементы из списка
;;; На основе http://www.theswamp.org/index.php?topic=19128.0
;;; Изменено для сравнения вещественных чисел (equal ... 1e-6)

  (while lst
    (setq head (car lst)
          OutList (cons head OutList)
          lst (vl-remove-if '(lambda(pt)(equal pt head 1e-6))(cdr lst))
          )
    )
  (reverse OutList)
  )
(defun mip:ZZero (lst)
  (mapcar '(lambda(x)(list (car x)(cadr x))) lst)
  )
(defun massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
    ))
  (reverse nlist))
(defun SELPOLY ( filter-list / pl lst ss)
;;; Выделение объектов, пересекаемых полилинией
;;; Vladimir Azarko (VVA) for dwg.ru
;;;  filter-list - фильтр список, см. описание ф-ции ssget или nil
;;; http://forum.dwg.ru/showthread.php?t=82243
;;;http://www.cadtutor.net/forum/showthread.php?68857-Counting-objects-not-blocks-in-a-polyline&p=471167#post471167
(vl-load-com)
(and
  (setq pl (mip:entsel "\nВыберите полилинию" '("LWPOLYLINE") nil))
  (setq lst (massoc 10 (entget pl)))
  (or (_Zoom2Lst lst) t)
  (setq ss nil
	ss
	 (if filter-list
	 (ssget
	   "_F"
	   (mip_MakeUniqueMembersOfList
	     (mapcar '(lambda(x)(trans x 0 1)) lst)
	     )
	     filter-list
	     )
	   (ssget
	   "_F"
	   (mip_MakeUniqueMembersOfList
	     (mapcar '(lambda(x)(trans x 0 1)) lst)
	     )
	   )
	   )
	)
  (sssetfirst nil ss)
  )
  ss
  )
(princ "\nНаберите SELPOLY или BSELPOLY в командной строке")

Который выбирает объекты (в частности блоки) и лисп из цитаты который пишет в атрибут блока расстояние от начала линии до точки выбранной на этой же линии.

Суть идеи в то чтобы всем блокам попадающим на данную линию в атрибут(можно конкретно названый) попадало значение расстояния от начала линии до точки их пересечения.
Интересно просто даже возможно ли это реализовать или я совсем замечтался.

Lumpy вне форума

Непрочитано

25.03.2021, 13:57

#43

Vladimir_Sergeevich

рисую дороги, в перерывах курю Lisp

Регистрация: 20.04.2011

Пермь

Сообщений: 475

<phrase 1=

Отправить сообщение для Vladimir_Sergeevich с помощью Skype™

Странно, что эта ветка не в программировании...

Цитата:

Сообщение от Lumpy

Посмотреть сообщение

Интересно просто даже возможно ли это реализовать или я совсем замечтался.

Вероятно понадобится только сама SELPOLY без оберток и много думать и писать... пример работы с атрибутами можно подсмотреть рядом

__________________
Не труд сделал из обезьяны человека, а лень и жажда халявы...

Vladimir_Sergeevich вне форума

Ответ

Вернуться

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

Обратная связь - Вверх