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

bimari · 20.10.2006, 15:53

Подскажите, пожалуйста как в 2006 акаде можно было определить расстояние от начала полилинии до любой ее точки. Было бы хорошо, если бы кликнув на эту точку появлялся Leader с расстоянием. Заранее спасибо!

Barmaley Bubusikin · 18.11.2020, 01:37

Цитата:

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

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

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

Цитата:

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

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

Lumpy · 24.03.2021, 16:42

Цитата:

Сообщение от 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 в командной строке")

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

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

Vladimir_Sergeevich · 25.03.2021, 13:57

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

Цитата:

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

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

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

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