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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Выравнивание полилинии в одну линию.

Выравнивание полилинии в одну линию.

Ответ
Поиск в этой теме
Непрочитано 25.03.2008, 14:55 #1
Выравнивание полилинии в одну линию.
f0lk
 
Регистрация: 16.10.2007
Сообщений: 7

Здравствуйте.
Есть полилиния - нужна программа которая выравнивает точки полилинии по одной прямой, со сохранением длин между вершинами полилинии.
С лиспом практически незнаком, а стандартными средствами такое сделать не получается.
Просмотров: 37811
 
Непрочитано 25.03.2008, 15:01
#2
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


1. Полилиния LW, 2d, 3d ?
2. Есть или нет дуговые сегменты?
3. Примерчик приложи
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Автор темы   Непрочитано 25.03.2008, 15:15
#3
f0lk


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


VVA :
2d полилиния без дуговых сегментов.

Технически это выглядело бы примерно так:
1. Взять координаты вершин полилинии.
2. Вычислить длину каждого сегмента.
3. Построить полилинию из заданной точки с заданными длинами. Либо математически изменить координаты вершин существующей линии.
Вот только в лиспе не силен, к сожалению.

Последний раз редактировалось f0lk, 25.03.2008 в 16:53.
f0lk вне форума  
 
Непрочитано 25.03.2008, 17:14
#4
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839


Примерчик (возможно) требует пригонки и обработки напильником

(defun c:razv ( / P lst2 lst n obj krd)
(setq krd 0 n 0 obj (entget (car (entsel "Выберите полилинию "))))
(if (/= (cdr (assoc 0 obj)) "LWPOLYLINE") (progn (alert "Это не LW полилиния") (exit)))
(setq p (trans (getpoint "Куда вставлять развертку ") 1 0))
;записывает координаты вершин
(while (/= krd nil)
(setq krd (nth n obj))
(if (= (car krd) 10) (setq lst (append lst (list (list (cadr krd) (caddr krd)))))
);end of if
(setq n (1+ n))
);end of while
;записывает расстояния
(setq n 0)
(while (/= (nth (1+ n) lst) nil)
(setq lst2 (append lst2 (list (distance (nth n lst) (nth (1+ n) lst))))
n (1+ n)
);end of setq
);end of while
;строит полилинию
(setq n 0)
(entmakex '((0 . "POLYLINE") (66 . 1)))
(entmakex (list '(0 . "VERTEX") (append '(10) (list (car p) (cadr P)))))
(while (/= (nth n lst2) nil)
(setq p (list (+ (car p) (nth n lst2)) (cadr p)))
(setq n (1+ n))
(entmakex (list '(0 . "VERTEX") (append '(10) (list (car p) (cadr P)))))
);end of while
(entmakex '((0 . "SEQEND")))
);end defun

P.S. Запускать командой "razv".
__________________
Когда в руках молоток все вокруг кажется гвоздями.

Последний раз редактировалось Дима_, 25.03.2008 в 21:40.
Дима_ вне форума  
 
Автор темы   Непрочитано 25.03.2008, 17:22
#5
f0lk


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


Дима - то что нужно!! Огромное спасибо!
f0lk вне форума  
 
Непрочитано 25.03.2008, 17:46
#6
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839


Не торопись благодорить - вначале погоняй как следует.
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Дима_ вне форума  
 
Непрочитано 25.03.2008, 21:40
#7
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839


А опять забыл - в не мировой пск - будет со смещением рисовать - исправил в 4-ом посте. (разворачивает все равно в мировую, но по моему так лучшее.)
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Дима_ вне форума  
 
Непрочитано 26.03.2008, 10:00
#8
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Я тут тоже немного размялся
RAZV1 - создает развернутую новую LW полилинию
RAZV2 - разворачивает существующую
Код:
[Выделить все]
(defun c:razv1 ( / ss ed vxLIST dstLIST newEd n Y X)
 (if 
 (and
   (princ "Выберите полилинию ")
   (setq ss (ssget "_+.:S:E:L" '((0 . "LWPOLYLINE"))))
   (setq ed (entget (ssname ss 0)))
   (mapcar '(lambda(x)(if(= (car x) 10)(setq vxLIST (cons (cdr x) vxLIST)))) ed)
   (setq ss nil vxLIST (reverse vxLIST))
   (setq dstLIST (mapcar 'distance vxLIST  (cdr vxLIST)))
   (setq dstLIST (cons 0 dstLIST))
   (setq n '-1 Y (cadar vxLIST) X (caar vxLIST))
   (foreach item ed
     (if (= (car item) 10)
       (setq item (list 10 (setq X (+ X (nth (setq n (1+ n)) dstLIST))) Y))
       )
     (setq newEd (cons item newEd))
     )
   )
 (entmakex (reverse newED))
 (princ "\nНе LW полилиния")
 )
  (princ)
  )
(defun c:razv2 ( / ss ed vxLIST dstLIST newEd n Y X)
 (if 
 (and
   (princ "Выберите полилинию ")
   (setq ss (ssget "_+.:S:E:L" '((0 . "LWPOLYLINE"))))
   (setq ed (entget (ssname ss 0)))
   (mapcar '(lambda(x)(if(= (car x) 10)(setq vxLIST (cons (cdr x) vxLIST)))) ed)
   (setq ss nil vxLIST (reverse vxLIST))
   (setq dstLIST (mapcar 'distance vxLIST  (cdr vxLIST)))
   (setq dstLIST (cons 0 dstLIST))
   (setq n '-1 Y (cadar vxLIST) X (caar vxLIST))
   (foreach item ed
     (if (= (car item) 10)
       (setq item (list 10 (setq X (+ X (nth (setq n (1+ n)) dstLIST))) Y))
       )
     (setq newEd (cons item newEd))
     )
   )
 (entmod (reverse newED))
 (princ "\nНе LW полилиния")
 )
  (princ)
  )
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 26.03.2008, 15:45
#9
CB

Конструирование в области нефтеразведки
 
Регистрация: 10.02.2006
Гомель
Сообщений: 321


Аналогично (в смысле размялся )
RAZV - создает развернутую новую LW полилинию

Код:
[Выделить все]
(defun c:razv (/ ent)
  (if (and (setq ent (car (entsel "\nВыберите полилинию: ")))
           (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
      ) ;_ end of and
    ((lambda (lst / test)
       (defun test (pt lst)
         (if (cadr lst)
           (cons pt
                 (test (polar pt 0. (distance (car lst) (cadr lst)))
                       (cdr lst)
                 ) ;_ end of test
           ) ;_ end of cons
           (list pt)
         ) ;_ end of if
       ) ;_ end of defun
       (entmake
         (append
           (list
             '(0 . "LWPOLYLINE")
             '(100 . "AcDbEntity")
             '(100 . "AcDbPolyline")
             (cons 90 (length lst))
           ) ;_ end of list
           (mapcar '(lambda (x) (cons 10 x)) (test (car lst) lst))
         ) ;_ end of append
       ) ;_ end of entmake
     ) ;_ end of lambda
      (mapcar 'cdr
              (vl-remove-if-not
                '(lambda (x) (= (car x) 10))
                (entget ent)
              ) ;_ end of vl-remove-if-not
      ) ;_ end of mapcar
    )
  ) ;_ end of if
  (princ)
) ;_ end of defun
CB вне форума  
 
Непрочитано 21.05.2008, 09:11
#10
Дмитррр

НЛО
 
Регистрация: 09.07.2007
Тутошние мы.
Сообщений: 6,403


А можно сделать так, что бы привязанные к узлам метки сохранялись и на разогнутой полилиние? (круги, линии, точки или блоки...)
Что-нибудь на подобие этого...
Миниатюры
Нажмите на изображение для увеличения
Название: Безымянный.jpg
Просмотров: 511
Размер:	15.4 Кб
ID:	6654  
Дмитррр вне форума  
 
Непрочитано 21.05.2008, 12:22
#11
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839


Копирует так-же круги и любые блоки, НО чтоб центр (или точка вставки для блока) лежали строго на вершине полилинии.
Код:
[Выделить все]
(defun c:razv2 ( / P lst lst2 lst3 n obj krd)
(setq krd 0 n 0 obj (entget (car (entsel "Выберите полилинию "))))
(if (/= (cdr (assoc 0 obj)) "LWPOLYLINE") (progn (alert "Это не LW полилиния") (exit)))
(setq p (trans (getpoint "Куда вставлять развертку ") 1 0))

;записывает координаты вершин
(while (/= krd nil)
(setq krd (nth n obj))
(if (= (car krd) 10) (setq lst (append lst (list (list (cadr krd) (caddr krd)))))
);end of if
(setq n (1+ n))
);end of while

;записывает расстояния 
(setq n 0)
(while (/= (nth (1+ n) lst) nil)
(setq lst2 (append lst2 (list (distance (nth n lst) (nth (1+ n) lst))))
n (1+ n)
);end of setq
);end of while

;записывает координаты новых вершин
(setq n 0 krd p lst3 (list krd))
(repeat (length lst2)
(setq
krd (list (+ (car krd) (nth n lst2)) (cadr krd))
lst3 (append lst3 (list krd))
n (1+ n)
);end of setq
);end of repeat

;строит полилинию
(pl lst3)

;переносит объекты
(setq obj (entnext))
(while (/= obj nil)
(if (or
	(= (cdr (assoc 0 (entget obj))) "CIRCLE")
	(= (cdr (assoc 0 (entget obj))) "INSERT")
)
(progn
(setq n 0)
(repeat (length lst3)
(if (equal (cdr (assoc 10 (entget obj))) (append (nth n lst) (list 0.0)) 1e-6)
(entmakex (cdr (subst (append (list 10) (nth n lst3)) (assoc 10 (entget obj)) (entget obj))))
);end of if
(setq n (1+ n))
);end of repeat
);end of progn
);end of if
(setq obj (entnext obj))
);end of while
);end defun

(defun pl (obj / ed n tmp); создает полилинию по списку вершин obj.
(setq 	ed (list (cons 0 "LWPOLYLINE")
		(cons 100 "AcDbEntity")
		(cons 100 "AcDbPolyline")
		(cons 90 (length obj)));end of list
	n 0
	tmp (nth n obj)
);end of setq
(while (/= tmp nil)
(setq 	ed (append ed (list (append (list 10) (nth n obj))))
	n (1+ n)
	tmp (nth n obj)
);end setq 
);end of while
(entmakex ed)
);end of defun
P.S. Запускать "RAZV2".
__________________
Когда в руках молоток все вокруг кажется гвоздями.

Последний раз редактировалось Дима_, 21.05.2008 в 12:57.
Дима_ вне форума  
 
Непрочитано 21.05.2008, 12:45
#12
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Дима_, Только я бы сравнивал координаты с допуском. У меня бывали случаи, когда 2 одинаковые точки не были equal

Код:
[Выделить все]
;Строчку
(equal (cdr (assoc 10 (entget obj))) (append (nth n lst) (list 0.0)))
;Записать так
(equal (cdr (assoc 10 (entget obj))) (append (nth n lst) (list 0.0)) 1e-6)
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 21.05.2008, 12:56
#13
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839


To VVA спасибо - я только учусь - подправил.
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Дима_ вне форума  
 
Непрочитано 21.05.2008, 13:13
#14
Profan


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


Слушайте, а не послать ли эту программу в раздел "Готовые программы"? Вроде бы, тот раздел надо пополнять, но я прекратил это, когда форум caduser.ru восстановился.
Profan вне форума  
 
Непрочитано 21.05.2008, 13:21
#15
Кулик Алексей aka kpblc
Moderator

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


Один из вариантов:
Код:
[Выделить все]
(defun test (/			    _kpblc-conv-ent-pline-vertex-to-wcs
	     _kpblc-conv-list-to-3dpoints
	     _dwgru-conv-pickset-to-list
	     adoc		    *error*
	     ent		    selset
	     base_pt		    len
	     space		    vertex_block
	     vertex_block_name	    new_obj
	     )

  (defun _kpblc-conv-list-to-3dpoints (lst / res)
				      ;|
*    Функция конвертации списка чисел в список 3-мерных точек.
*    Параметры вызова:
*	lst	список чисел
*    Примеры вызова:
(_kpblc-conv-list-to-3dpoints '(1 2 3 4 5 6)) ;-> ((1 2 3) (4 5 6))
(_kpblc-conv-list-to-3dpoints '(1 2 3 4 5))   ;-> ((1 2 3) (4 5 0.))
|;
    (cond
      ((not lst)
       nil
       )
      (t
       (setq res (cons (list (car lst)
			     (if (cadr lst)
			       (cadr lst)
			       0.
			       ) ;_ end of if
			     (if (caddr lst)
			       (caddr lst)
			       0.
			       ) ;_ end of if
			     ) ;_ end of list
		       (_kpblc-conv-list-to-3dpoints (cdddr lst))
		       ) ;_ end of cons
	     ) ;_ end of setq
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun

  (defun _kpblc-conv-ent-pline-vertex-to-wcs (ent / elevation normal)
					     ;|
*    Функция получения координат легкой полилинии (LWPOLYLINE) в WCS. Возвращает
* список 3Д-точек
*    Автор: BOZ (http://www.autocad.ru/cgi-bin/f1/board.cgi?t=26461HC)
*    Оригинальный код:
(defun lwpoly_vert (lwpoly / plinee elev vnv)
  (setq	plinee (entget lwpoly)
	elev   (cdr (assoc 38 plinee))
	vnv    (cdr (assoc 210 plinee))
	) ;_ end of setq
  (mapcar
    (function (lambda (x) (trans (list (cadr x) (caddr x) elev) vnv 0)))
    (vl-remove-if-not (function (lambda (x) (= (car x) 10))) plinee)
    ) ;_ end of mapcar
  ) ;_ end of defun
*    Параметры вызова:
*	ent	ename-указатель на LWPOLYLINE (контроля не производится)
*    Примеры вызова:
(_kpblc-conv-ent-pline-vertex-to-wcs (car (entsel)))
|;
    (setq elevation (cdr (assoc 38 (entget ent)))
	  normal    (cdr (assoc 210 (entget ent)))
	  ) ;_ end of setq
    (if	(not elevation)
      (setq elevation 0.)
      ) ;_ end of if
    (mapcar '(lambda (x) (trans (list (cadr x) (caddr x) elevation) normal 0))
	    (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))
	    ) ;_ end of mapcar
    ) ;_ end of defun

  (defun _dwgru-conv-pickset-to-list (value / tab item)
    (repeat (setq tab  nil
		  item (sslength value)
		  ) ;_ end setq
      (setq tab (cons (ssname value (setq item (1- item))) tab))
      ) ;_ end repeat
    ) ;_ end defun

  (defun *error* (msg)
    (vla-regen adoc acactiveviewport)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (if
    (and
      (= (type (setq ent
		      (vl-catch-all-apply
			'(lambda ()
			   (car
			     (entsel
			       "\nУкажите полилинию или сплайн для разворачивания <Отмена> : "
			       ) ;_ end of entsel
			     ) ;_ end of car
			   ) ;_ end of lambda
			) ;_ end of vl-catch-all-apply
		     ) ;_ end of setq
	       ) ;_ end of type
	 'ename
	 ) ;_ end of =
      (member (cdr (assoc 0 (entget ent))) '("LWPOLYLINE" "SPLINE"))
      ((lambda ()
	 (prompt
	   "\nВыберите точки, блоки или окружности, располагающиеся на разворачиваемом примитиве <Отмена> : "
	   ) ;_ end of prompt
	 (setq selset (ssget '((0 . "INSERT,POINT,CIRCLE"))))
	 ) ;_ end of lambda
       )
      (= (type
	   (setq
	     base_pt (vl-catch-all-apply
		       '(lambda	()
			  (getpoint
			    "\nНачальная точка отрисовки развертки <Отмена> : "
			    ) ;_ end of getpoint
			  ) ;_ end of lambda
		       ) ;_ end of vl-catch-all-apply
	     ) ;_ end of setq
	   ) ;_ end of type
	 'list
	 ) ;_ end of =
      ) ;_ end of and
     (progn
       (setq ent	       (vlax-ename->vla-object ent)
	     len	       (vlax-curve-getdistatpoint ent (vlax-curve-getendpoint ent))
	     space	       (vla-objectidtoobject adoc (vla-get-ownerid ent))
	     selset	       (vl-remove-if-not
				 '(lambda (x)
				    (vlax-curve-getdistatpoint ent (cdr (assoc 10 (entget x))))
				    ) ;_ end of lambda
				 (_dwgru-conv-pickset-to-list selset)
				 ) ;_ end of vl-remove-if-not
	     vertex_block_name "dwgru-vertex"
	     vertex_block      (if (tblobjname "block" vertex_block_name)
				 (vla-item (vla-get-blocks adoc) vertex_block_name)
				 ((lambda (/ res)
				    (setq res (vla-add (vla-get-blocks adoc)
						       (vlax-3d-point '(0. 0. 0.))
						       vertex_block_name
						       ) ;_ end of vla-add
					  ) ;_ end of setq
				    (vla-addcircle res (vlax-3d-point '(0. 0. 0.)) 5.)
				    (vla-addline
				      res
				      (vlax-3d-point '(-5. -5. 0.))
				      (vlax-3d-point '(5. 5. 0.))
				      ) ;_ end of vla-AddLine
				    (vla-addline
				      res
				      (vlax-3d-point '(-5. 5. 0.))
				      (vlax-3d-point '(5. -5. 0.))
				      ) ;_ end of vla-AddLine
				    (vlax-for sub res
				      (vla-put-layer sub "0")
				      (vla-put-color sub 3)
				      (vla-put-linetype sub "Continuous")
				      (vla-put-lineweight sub aclnwtbyblock)
				      ) ;_ end of vlax-for
				    res
				    ) ;_ end of lambda
				  )
				 ) ;_ end of if
	     new_obj	       (append
				 (list
				   (vla-addline
				     space
				     (vlax-3d-point base_pt)
				     (vlax-3d-point
				       (list (+ (car base_pt) len)
					     (cadr base_pt)
					     (caddr base_pt)
					     ) ;_ end of list
				       ) ;_ end of vlax-3d-point
				     ) ;_ end of vla-addline
				   ) ;_ end of list
				 (mapcar
				   '(lambda (x / tmp res)
				      (setq tmp	(vlax-curve-getdistatpoint ent x)
					    res	(cons (vla-insertblock
							space
							(vlax-3d-point
							  (list	(+ (car base_pt) tmp)
								(cadr base_pt)
								(caddr base_pt)
								) ;_ end of list
							  ) ;_ end of vlax-3d-point
							vertex_block_name
							1.
							1.
							1.
							0.
							) ;_ end of vla-InsertBlock
						      res
						      ) ;_ end of cons
					    ) ;_ end of setq
				      res
				      ) ;_ end of lambda
				   (cond
				     ((wcmatch (strcase (vla-get-objectname ent)) "*POLYLINE")
				      (_kpblc-conv-ent-pline-vertex-to-wcs
					(vlax-vla-object->ename ent)
					) ;_ end of _kpblc-conv-ent-pline-vertex-to-wcs
				      )
				     ((wcmatch (strcase (vla-get-objectname ent)) "*SPLINE")
				      (_kpblc-conv-list-to-3dpoints
					(vlax-safearray->list
					  (vlax-variant-value (vla-get-fitpoints ent))
					  ) ;_ end of vlax-safearray->list
					) ;_ end of _kpblc-conv-list-to-3dpoints
				      )
				     ) ;_ end of cond
				   ) ;_ end of mapcar
				 (mapcar
				   '(lambda (x / tmp)
				      (setq tmp	(vlax-curve-getclosestpointto
						  ent
						  (cdr (assoc 10 (entget x)))
						  ) ;_ end of vlax-curve-getclosestpointto
					    ) ;_ end of setq
				      (vlax-ename->vla-object
					(entmakex
					  (subst
					    (cons 10
						  (list	(+ (car base_pt)
							   (vlax-curve-getdistatpoint ent tmp)
							   ) ;_ end of +
							(cadr base_pt)
							(caddr base_pt)
							) ;_ end of list
						  ) ;_ end of cons
					    (assoc 10 (entget x))
					    (vl-remove-if
					      '(lambda (a)
						 (member (car a) '(-1 330 5))
						 ) ;_ end of lambda
					      (entget x)
					      ) ;_ end of vl-remove-if
					    ) ;_ end of subst
					  ) ;_ end of entmakex
					) ;_ end of vlax-ename->vla-object

				      ) ;_ end of lambda
				   selset
				   ) ;_ end of mapcar
				 ) ;_ end of append
	     ) ;_ end of setq
       (princ)
       ) ;_ end of progn
     ) ;_ end of if
  (vla-regen adoc acactiveviewport)
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
Создает отрезок длиной в разворачиваемый примитив; проставляет вершины исходного примитива; обрабатывает точки, круги и блоки. Исключает не попадающие на примитив. Короче, протестируй, если есть желание.
---
Добавлено: слои должны быть разморожены и разблокированы (этот контроль не выполняется). Отрисовка нового отрезка и простановка блоков вершин выполняется на текущем слое с текущими установками; точки, блоки и окружности - копируются исходные.
---
Добавлено, часть 2: и тишина...
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.

Последний раз редактировалось Кулик Алексей aka kpblc, 22.05.2008 в 23:02.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 27.05.2008, 13:48
#16
f0lk


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


Кулик Алексей aka kpblc - пытаюсь разобраться с функциями =)
Можно ли сделать так чтобы не только окружности и блоки разворачивались, а также отрезки, в идеале еще и выноски, не обязательно красиво - это уже мелочи =)
Всем откликнувшимся огромное спасибо!
f0lk вне форума  
 
Непрочитано 27.05.2008, 14:11
#17
Кулик Алексей aka kpblc
Moderator

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


Чего-чего?? ОБразец в студию!
Хотя... ближайшие два дня точно не сяду - не до того будет
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 27.05.2008, 15:14
#18
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839


А выноску в блок загнать?
__________________
Когда в руках молоток все вокруг кажется гвоздями.
Дима_ вне форума  
 
Непрочитано 01.07.2008, 15:36
#19
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


Посоветуйте пожалуйста, как поступить в моем случае. В прикрепленном чертеже желтая полилиния и ее пересекает некое кол-во полилиний других цветов. Хотелось бы выпрямить желтую так, чтобы остальные остались ее пересекать в тех же местах, т.е. на тех же расстояниях от начала желтой. Реально ли осуществить?
Вложения
Тип файла: dwg
DWG 2007
Чертеж.dwg (75.1 Кб, 1694 просмотров)

Последний раз редактировалось skkkk, 01.07.2008 в 16:19.
skkkk вне форума  
 
Непрочитано 01.07.2008, 16:13
#20
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


Думается, надо загнать каждую из пересекаемых линий в блок. Тогда возникает вопрос, как загнать в блок их попроще (меньшими телодвижениями)? Что-то типа нажать кнопку на панели, затем кликнуть объект - (оп!) и он уже блок (без диалоговых окон)....Может есть в КАДе стандартное решение, но я его не знаю
skkkk вне форума  
 
Непрочитано 01.07.2008, 16:49
#21
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Цитата:
Тогда возникает вопрос, как загнать в блок их попроще
Все выбранное в блок. Напомните ЛИСП
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 01.07.2008, 17:38
#22
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Одно НО
В SETUB3 точка вставки блока посередине габарита (для отрезков - посередине), а для кода Дима_ нужно
Цитата:
НО чтоб центр (или точка вставки для блока) лежали строго на вершине полилинии
Но по моему этого не требуется в коде Алексея
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 01.07.2008, 19:17
#23
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


Алексей, а в твоем коде (#15) что это за зеленые мишени по бывшим вершинам появляются на распрямленном отрезке? Можно их убрать? И на него (отрезок) из всех выбранных мной блоков почему-то переносится только первый. И еще у меня оба лиспа (второй - от Димы_) выпрямленную линию делают задом наперед. С чего бы это вдруг?? Не страшно, конечно, Rotate спасает, но изящность процесса портится

VVA , в лиспе Алексея тоже надо, чтобы точка вставки блока совпадала с вершиной

Последний раз редактировалось skkkk, 01.07.2008 в 19:26.
skkkk вне форума  
 
Непрочитано 01.07.2008, 22:16
#24
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Не знаю, я детально не анализировал, Алексею видней всех.
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 01.07.2008, 23:46
#25
Кулик Алексей aka kpblc
Moderator

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


skkkk, #23 в продолжение #19 и на его основе?
"Зеленые" типа точки - на самом деле блоки, которые показывать должны старое положение вершин.
Не очень понял - что значит "задом наперед". Она лично у меня отрисовывается слева направо в текущей системе координат. А вершины располагаются начиная с первой по направлению отрисовки полилинии. Хочешь - попробуй инвертировать направление (см. http://dwg.ru/dnl/607)
Вопрос с "поворотом" пересекающих объектов лично я сейчас решить не в силах - прилично аналитики надо прописывать, чтоб добиться приемлемого результата (
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 02.07.2008, 02:35
#26
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
skkkk, #23 в продолжение #19 и на его основе?
(
именно так

А у меня почему-то выпрямленная линия отрисовывается справа налево, причем и твоим лиспом и Диминым_

Помнится мне, речь шла о допуске...
Цитата:
Сообщение от Дима_ Посмотреть сообщение
НО чтоб центр (или точка вставки для блока) лежали строго на вершине полилинии.
Цитата:
Сообщение от VVA Посмотреть сообщение
Дима_, Только я бы сравнивал координаты с допуском. У меня бывали случаи, когда 2 одинаковые точки не были equal
...нельзя ли этот допуск увеличить? Так, чтобы центры блоков, отстоящие от ближайшей вершины, допустим, на 0,5 единиц, тоже шли в зачет....
skkkk вне форума  
 
Непрочитано 02.07.2008, 02:41
#27
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


VVA, а ведь эту (эти) команду можно добавить в PLTOOLS, не считаете?
Добавлено: Разумеется, с согласия авторов

Последний раз редактировалось skkkk, 02.07.2008 в 14:17.
skkkk вне форума  
 
Непрочитано 02.07.2008, 10:27
#28
Дима_

Продуман
 
Регистрация: 22.02.2007
Питер
Сообщений: 2,839


Цитата:
Сообщение от skkkk Посмотреть сообщение
А у меня почему-то выпрямленная линия отрисовывается справа налево, причем и твоим лиспом и Диминым_

Помнится мне, речь шла о допуске...


...нельзя ли этот допуск увеличить? Так, чтобы центры блоков, отстоящие от ближайшей вершины, допустим, на 0,5 единиц, тоже шли в зачет....
1 - Скорее всего ты на эту линию снизу "смотришь".
2 - (if (equal (cdr (assoc 10 (entget obj))) (append (nth n lst) (list 0.0)) 1e-6) и есть допуск.

P.S. А понял в чем дело - скорее всего линия с права на лево получаеться потому, что исходная полилиния идет с права на лево, а сканирует программа с начала линии, исправить это без проблем, но я сейчас в отпуске и на рыбалку укатываю, через 2 дня если никто не исправит, перепишу. Пока можешь написать, что делать если исходные точки одна под другой окажется (по одной X координате) - откуда сканировать сверху вниз или наоборот.
__________________
Когда в руках молоток все вокруг кажется гвоздями.

Последний раз редактировалось Дима_, 02.07.2008 в 10:46.
Дима_ вне форума  
 
Непрочитано 02.07.2008, 15:26
#29
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


Дима_, удачного улова, и не забудь(те) взять удочки, а то я знаю, как в России рыбалка бывает

А нельзя как-то придумать снятие вообще этого ограничения насчет соответствия вершин полилинии точкам вставки блоков? Если пересекает блок (а лучше - отрезок)в любом месте, значит переносится на выпрямляемую линию... Было бы здорово. Ведь не все пересекаемые линии проходят через центр (см. во вложении). Может, как-то можно лиспом Согласовать ориентацию блока с ориентацией объекта по аналогии с командой _measure АвтоКАДа?

А по поводу справа налево. Осенило меня тут.....я сглупил конкретно, головой меня об кирпич. Конечно же, я отрисовывал эту полилинию справа налево, а то что она рисуется наоборот, так мне же так и надо!!!! Так что этот момент переделывать ни к чему
Вложения
Тип файла: dwg
DWG 2007
Чертеж.dwg (86.8 Кб, 1707 просмотров)

Последний раз редактировалось skkkk, 02.07.2008 в 15:46.
skkkk вне форума  
 
Непрочитано 02.07.2008, 18:52
#30
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Ну вот по быстрому что-то сфарганил. По идее должна разворачивать все пересекающие полилинию объекты. Особо не теститровал. Поэтому лучше пока сразу выставить МСК
Код:
[Выделить все]
(defun c:razv3 ( / P lst lst2 lst3 n obj krd)
(setq lst nil lst2 nil lst3 nil krd 0 n 0 obj (entget (car (entsel "Выберите полилинию "))))
(if (/= (cdr (assoc 0 obj)) "LWPOLYLINE") (progn (alert "Это не LW полилиния") (exit)))
(setq p (trans (getpoint "Куда вставлять развертку ") 1 0))

;записывает координаты вершин
(while (/= krd nil)
(setq krd (nth n obj))
(if (= (car krd) 10) (setq lst (append lst (list (list (cadr krd) (caddr krd)))))
);end of if
(setq n (1+ n))
);end of while

;записывает расстояния 
(setq n 0)
(while (/= (nth (1+ n) lst) nil)
(setq lst2 (append lst2 (list (distance (nth n lst) (nth (1+ n) lst))))
n (1+ n)
);end of setq
);end of while

;записывает координаты новых вершин
(setq n 0 krd p lst3 (list krd))
(repeat (length lst2)
(setq
krd (list (+ (car krd) (nth n lst2)) (cadr krd))
lst3 (append lst3 (list krd))
n (1+ n)
);end of setq
);end of repeat

;строит полилинию
(pl lst3)
(if (and (setq ss (ssget "_F" (mapcar '(lambda(x)(trans x 0 1)) lst)))
	 (ssdel (cdr(assoc -1 obj)) ss)
	 (> (sslength ss) 0)
	 )
  (progn
    (mapcar '(lambda(item / vla-obj pt-rot index flag segN)
	       (setq vla-obj (vlax-ename->vla-object (cadr item)))
	       (setq vla-obj (vla-copy vla-obj))
	       (setq pt-rot (trans(cadr(last item)) 1 0))
	       (setq flag t index '-1 segn nil)
	       (mapcar '(lambda (p1 p2)
			  (setq index (1+ index))
			  (if (and flag
				   (equal (distance p1 p2)
					  (+ (distance p1 pt-rot)
					     (distance pt-rot p2)
					     )
					  1e-3)
				   )
			    (setq flag nil segN index)
			    )
			  )
		       lst (cdr lst)
		       )
	       (if segN
		 (progn
	       (vla-rotate vla-obj (vlax-3d-point (append (nth segN lst)(list (cdr(assoc 38 obj)))))
			       (- (* 2 pi)(angle (nth segN lst)(nth (1+ segN) lst)))
			       )
	       (vla-move vla-obj (vlax-3d-point (append (nth segN lst)(list (cdr(assoc 38 obj)))))
			          (vlax-3d-point (nth segN lst3))
			 )
	       )
		 )
	       )
    (ssnamex ss)
	    )
    )
  )
  (princ)
);end defun

(defun pl (obj / ed n tmp); создает полилинию по списку вершин obj.
(setq 	ed (list (cons 0 "LWPOLYLINE")
		(cons 100 "AcDbEntity")
		(cons 100 "AcDbPolyline")
		(cons 90 (length obj)));end of list
	n 0
	tmp (nth n obj)
);end of setq
(while (/= tmp nil)
(setq 	ed (append ed (list (append (list 10) (nth n obj))))
	n (1+ n)
	tmp (nth n obj)
);end setq 
);end of while
(entmakex ed)
);end of defun
*** Добавлено
>Skkkk В полилинии в твоем примере из #29 есть дублирующиеся вершины. Обработай до применения RAZV3 командой PL-VxOpt и (если нужно) Entrevs.
Это ,наверное, станет очередным кандидатом в pltools (возможно в 2-х варинтах: просто развертка полилинии и развертка с пересекающими полилинию объектами)
__________________
Как использовать код на Лиспе читаем здесь

Последний раз редактировалось VVA, 02.07.2008 в 19:00.
VVA вне форума  
 
Непрочитано 02.07.2008, 19:28
#31
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


VVA, не разворачивает у меня пересекающие объекты. Рисует только прямую полилинию

Добавлено:
Прошу прощения. Это относится только к прикрепленному чертежу из #29. Там все так. Ну этот чертеж, видимо, многое вытерпел....
Попробовал на новом, все работает. Огромное спасибо, Владимир. А можно дополнить код так, чтобы от развернутой полилинии в местах пересечения рисовались отрезки длиной 40мм по направлению вверх? Только если несложно

Последний раз редактировалось skkkk, 02.07.2008 в 20:39.
skkkk вне форума  
 
Непрочитано 02.07.2008, 22:51
#32
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Цитата:
Сообщение от skkkk Посмотреть сообщение
Это относится только к прикрепленному чертежу из #29. Там все так. Ну этот чертеж, видимо, многое вытерпел....
Из #30
Цитата:
>Skkkk В полилинии в твоем примере из #29 есть дублирующиеся вершины. Обработай до применения RAZV3 командой PL-VxOpt и (если нужно) Entrevs.
В полилинии не должно быть дублирующихся вершин, иначе не работает выбор _fence в ssget
>skkkk #31 В местах пересечения чего с чем?
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 02.07.2008, 23:05
#33
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


Цитата:
Сообщение от VVA Посмотреть сообщение
Из #30

В полилинии не должно быть дублирующихся вершин, иначе не работает выбор _fence в ssget
Не заметил..

Цитата:
Сообщение от VVA Посмотреть сообщение
>skkkk #31 В местах пересечения чего с чем?
Вот тут во вложении красные линии. Только красными их делать не надо
Вложения
Тип файла: dwg
DWG 2007
Чертеж1.dwg (60.3 Кб, 1694 просмотров)
skkkk вне форума  
 
Непрочитано 23.07.2008, 05:00
#34
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


VVA, почему-то некорректно разворачивается полилиния в примере. Длина развернутой не совпадает с длиной оригинала (при проверке entlen'ом и в свойствах). Не знаете, в чем может быть дело? Всю голову сломал. МСК стоит. Круглая часть полилинии создана обрезкой круга и присоединением pedit'ом, только на ней замечена такая ошибка. И еще не все коротенькие черточки переносит. А еще мне неясно, почему файл так много весит?? Вроде всего две поли там, да несколько отрезков....
P.S. Речь о лиспе с #30
Вложения
Тип файла: dwg
DWG 2007
Пример.dwg (472.7 Кб, 1720 просмотров)
skkkk вне форума  
 
Непрочитано 03.04.2013, 04:48 подскажите с лиспом
#35
Gri05-1


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


Доброго всем дня! Проьлемка в том, что есть не ровные полилинии которые нужно сделать ровными и той же длины. Лисп razv подходит, но только для горизонтальных, а если у меня вертикальные линии прога их на 90 градусов поворачивает.. В чертеже у меня они то так и должны быть, ровные верт-ые и ровные гориз-ые. Я до этого скачивал лисп - l_align_xy Александра Ривилиса, она делает все как полагается, единственно только на отрезках... Подскажите как проблему решить или ссылочку на нужный лисп киньте... А надо простые полилинии и 3д полилинии. Заранее благодарен!
Gri05-1 вне форума  
 
Непрочитано 03.04.2013, 11:46
#36
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


Неточная постановка вопроса. Как неровные линии могут быть горизонтальными или вертикальными? Лучше приложить пример в dwg с нарисованными вариантами и их описанием, что есть и что надо.
skkkk вне форума  
 
Непрочитано 03.04.2013, 14:23
#37
sertor

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


Цитата:
Сообщение от Gri05-1 Посмотреть сообщение
а если у меня вертикальные линии прога их на 90 градусов поворачивает.
Я так понимаю, что пост написан в развитие этой темы.
__________________
Как-то так.
sertor вне форума  
 
Непрочитано 03.04.2013, 19:11
#38
skkkk


 
Регистрация: 20.03.2008
Сообщений: 2,680


Offtop: sertor, это она и есть "эта" тема
skkkk вне форума  
 
Непрочитано 03.04.2013, 20:03
#39
sertor

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


Цитата:
Сообщение от skkkk Посмотреть сообщение
sertor, это она и есть "эта" тема
Offtop: Точно. Прошу прощения за невнимательность, хотелось направить в "нужное русло".
__________________
Как-то так.
sertor вне форума  
 
Непрочитано 04.04.2013, 04:18
#40
Gri05-1


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


Прикладываю файл автокада. Не судите строго, может чего не так делаю..
Вложения
Тип файла: rar полилинии.rar (32.3 Кб, 78 просмотров)
Gri05-1 вне форума  
 
Непрочитано 24.03.2021, 04:22
#41
gette


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


Цитата:
Сообщение от VVA Посмотреть сообщение
Ну вот по быстрому что-то сфарганил. По идее должна разворачивать все пересекающие полилинию объекты. Особо не теститровал. Поэтому лучше пока сразу выставить МСК
Спасибо. Отлично работает, за исключением одного но - если исходная полилиния пересекает объект дважды/трижды/множество раз другой объект, то на результирующей отображается только один раз этот объект, а не в каждой точке пересечения.
Если бы еще иметь возможность захватывать близлежащие объекты (в указанном диапазоне/коридоре) и корректно наносить их на развертку, цены бы этому коду не было.
gette вне форума  
 
Непрочитано 06.07.2023, 13:14
#42
natural_gl


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


Цитата:
Сообщение от Дима_ Посмотреть сообщение
Копирует так-же круги и любые блоки, НО чтоб центр (или точка вставки для блока) лежали строго на вершине полилинии.
Код:
[Выделить все]
(defun c:razv2 ( / P lst lst2 lst3 n obj krd)
(setq krd 0 n 0 obj (entget (car (entsel "Выберите полилинию "))))
(if (/= (cdr (assoc 0 obj)) "LWPOLYLINE") (progn (alert "Это не LW полилиния") (exit)))
(setq p (trans (getpoint "Куда вставлять развертку ") 1 0))

;записывает координаты вершин
(while (/= krd nil)
(setq krd (nth n obj))
(if (= (car krd) 10) (setq lst (append lst (list (list (cadr krd) (caddr krd)))))
);end of if
(setq n (1+ n))
);end of while

;записывает расстояния 
(setq n 0)
(while (/= (nth (1+ n) lst) nil)
(setq lst2 (append lst2 (list (distance (nth n lst) (nth (1+ n) lst))))
n (1+ n)
);end of setq
);end of while

;записывает координаты новых вершин
(setq n 0 krd p lst3 (list krd))
(repeat (length lst2)
(setq
krd (list (+ (car krd) (nth n lst2)) (cadr krd))
lst3 (append lst3 (list krd))
n (1+ n)
);end of setq
);end of repeat

;строит полилинию
(pl lst3)

;переносит объекты
(setq obj (entnext))
(while (/= obj nil)
(if (or
	(= (cdr (assoc 0 (entget obj))) "CIRCLE")
	(= (cdr (assoc 0 (entget obj))) "INSERT")
)
(progn
(setq n 0)
(repeat (length lst3)
(if (equal (cdr (assoc 10 (entget obj))) (append (nth n lst) (list 0.0)) 1e-6)
(entmakex (cdr (subst (append (list 10) (nth n lst3)) (assoc 10 (entget obj)) (entget obj))))
);end of if
(setq n (1+ n))
);end of repeat
);end of progn
);end of if
(setq obj (entnext obj))
);end of while
);end defun

(defun pl (obj / ed n tmp); создает полилинию по списку вершин obj.
(setq 	ed (list (cons 0 "LWPOLYLINE")
		(cons 100 "AcDbEntity")
		(cons 100 "AcDbPolyline")
		(cons 90 (length obj)));end of list
	n 0
	tmp (nth n obj)
);end of setq
(while (/= tmp nil)
(setq 	ed (append ed (list (append (list 10) (nth n obj))))
	n (1+ n)
	tmp (nth n obj)
);end setq 
);end of while
(entmakex ed)
);end of defun
P.S. Запускать "RAZV2".
Не подскажите в чем проблема? пытаюсь развернуть полилинию но смотрю длина развернутой линии отилчается от исходной. прикрепляю файл dwg
Вложения
Тип файла: dwg
DWG 2013
Развертка.dwg (115.9 Кб, 11 просмотров)
natural_gl вне форума  
 
Непрочитано 06.07.2023, 16:03
#43
AlexCondor

инженер
 
Регистрация: 03.08.2007
Сообщений: 1,402


natural_gl, Ну не дружит эта програмулина с дугами.
AlexCondor вне форума  
 
Непрочитано 07.07.2023, 13:17
#44
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,809


Цитата:
Сообщение от natural_gl Посмотреть сообщение
развернуть полилинию
без всяко-разных блоков, просто распрямление полилинии.
Код:
[Выделить все]
 
(defun c:straighten_pline (/ pline_ename vertex_index vertex_length_list straightened_pline_starting_point
							 straightened_pline_vertex_list
						  )
	(while (and
				(setq pline_ename (car (entsel "\nВыберите полилинию для распрямления: ")))
				(null (= "LWPOLYLINE" (cdr (assoc 0 (entget pline_ename)))))
		   )
	)
	(if pline_ename
		(progn
			(setq vertex_index -1)
			(repeat (1+ (fix (vlax-curve-getendparam pline_ename)))
				(setq vertex_length_list (append vertex_length_list 
												(list (vlax-curve-getdistatparam pline_ename 
																				(setq vertex_index (1+ vertex_index))
													  )
												)
										 )
				)
			)
			(setq straightened_pline_starting_point (trans (getpoint "\nУкажите начальную точку для распрямлённой полилинии: ") 1 0)
				  straightened_pline_vertex_list (mapcar '(lambda (_length) (list (+ _length (car straightened_pline_starting_point)) 
				  																  (cadr straightened_pline_starting_point)
																			)
														  )
														  vertex_length_list
												 )
			)
			(vla-addlightweightpolyline (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))) 
										(vlax-safearray-fill 
											(vlax-make-safearray 
												vlax-vbdouble 
												(cons 1 (length (apply 'append straightened_pline_vertex_list)))
											)
											(apply 'append straightened_pline_vertex_list)
										)
			)
		)
	)
	(princ)
)
__________________
K Lisp
koMon вне форума  
 
Непрочитано 26.06.2024, 04:52
#45
mvartem


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


Привет! А если полилиния 3Д? Её можно развернуть с сохранением Z координаты в вершинах? 3Д полилиния безо всяких дуг. Очень пригодилось бы для построения профилей
mvartem вне форума  
 
Непрочитано 27.06.2024, 19:05
#46
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,809


Цитата:
Сообщение от mvartem Посмотреть сообщение
3Д полилиния безо всяких дуг.
3d полилиния в автокаде не может иметь дуговых сегментов.
__________________
K Lisp
koMon вне форума  
 
Непрочитано 01.07.2024, 11:06
#47
mvartem


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


Цитата:
Сообщение от koMon Посмотреть сообщение
3d полилиния в автокаде не может иметь дуговых сегментов.
Хорошо, пусть так. Но возможен ли вариант разворачивания 3Д полилинии с сохранением Z координаты в вершинах?
mvartem вне форума  
 
Непрочитано 01.07.2024, 11:29
#48
name02


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


Цитата:
Сообщение от mvartem Посмотреть сообщение
разворачивания 3Д полилинии с сохранением Z координаты в вершинах?
После разворачивания 3Д полилинии будут только две коородинаты - одна координата будет идти вдоль "профиля", а вторая будет соответствовать высотной отметке вершин 3Д полилинии

Вот программа, которая разворачивает 3Д полилинию в 2Д полилинию в плоскости XY (координат Z становится координатой Y):
PL2Profile.lsp
Код:
[Выделить все]
 (vl-load-com)

(defun C:PL2Profile (/ pt3d->2d ss en pt1 pt2 dpts)

  (defun pt3d->2d (pt / ) (reverse (cons 0. (cdr (reverse pt)))))
  
  (prompt "\nRequired a SINGLE 3D Polyline,")
  (if (and (setq ss (ssget "_+.:E:S" '((0 . "POLYLINE"))))
	   (= 1 (sslength ss))
	   (setq en (ssname ss 0)))
    (progn
      (repeat (setq par (fix (vlax-curve-getEndParam en)))
	(setq pt1 (vlax-curve-getPointAtParam en par)
	      pt2 (vlax-curve-getPointAtPAram en (setq par (1- par)))
	      dpts (cons (list (distance (pt3d->2d pt1)
					 (pt3d->2d pt2))
			       (- (last pt2)
				  (last pt1)))
			 dpts)))
      (command "_.pline") (princ " ...for the profile: ") (command PAUSE)
      (repeat (length dpts)
	(command "_none" (polar (polar (getvar 'LASTPOINT)
				       0
				       (caar dpts))
				(* 0.5 pi)
				(* (cadar dpts) 1))) ; Evelation scale (profile's y)
	(setq dpts (cdr dpts)))
      (command "")))
)
Взято отсюда https://forums.autodesk.com/t5/visua...e/td-p/5825544
name02 вне форума  
 
Непрочитано 02.07.2024, 22:19
#49
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,809


Цитата:
Сообщение от mvartem Посмотреть сообщение
вариант разворачивания 3Д полилинии с сохранением Z координаты в вершинах
распрямляется в 3d полилинию вдоль оси X в плоскости x0z.
Код:
[Выделить все]
 
(defun c:straighten_3d_pline (/ 3d_pline straightened_3d_pline_starting_point 3d_pline_vertices_raw_list 3d_pline_vertices_list
			        3d_pline_segment_list straightened_3d_pline_point_list next_x 3d_pline_z_list
			     )
  (setq 3d_pline (vlax-ename->vla-object (car (entsel "\nВыберите 3d полилинию: ")))
	straightened_3d_pline_starting_point (getpoint "\nУкажите начальную точку для распрямлённой 3d полилинии: ")
	3d_pline_vertices_raw_list (vlax-get 3d_pline 'coordinates)
  )
  (while 3d_pline_vertices_raw_list
	(setq 3d_pline_vertices_list (append 3d_pline_vertices_list (list (list (car 3d_pline_vertices_raw_list)
									    	(cadr 3d_pline_vertices_raw_list)
									        (caddr 3d_pline_vertices_raw_list)
								          )
								    )
				    )
	      3d_pline_vertices_raw_list (cdddr 3d_pline_vertices_raw_list)
	)  
  )
  (setq 3d_pline_z_list (mapcar 'caddr 3d_pline_vertices_list) 
  	3d_pline_segment_list (mapcar '(lambda (start end) (list start end)) 3d_pline_vertices_list (cdr 3d_pline_vertices_list))
  	straightened_3d_pline_point_list (mapcar '(lambda (deltas) (list (sqrt (apply '+ (mapcar '* deltas deltas '(1.0 1.0))))
									 (cadr straightened_3d_pline_starting_point)
									 (caddr deltas)
								   )
						  )
				    	          (mapcar '(lambda (segment) (mapcar '- (cadr segment) (car segment))) 3d_pline_segment_list)
			 	         )
  	next_x (car straightened_3d_pline_starting_point) 
  	straightened_3d_pline_point_list (mapcar '(lambda (point) (list (setq next_x (+ next_x (car point)))
									(cadr point)
									(caddr point)
								  )
						  )
						  straightened_3d_pline_point_list
				   	 )
  	straightened_3d_pline_point_list (append (list straightened_3d_pline_starting_point) straightened_3d_pline_point_list)
	straightened_3d_pline_point_list (mapcar '(lambda (point z) (list (car point) (cadr point) z)) straightened_3d_pline_point_list 3d_pline_z_list)
  )
  (vla-add3dpoly (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object)))) 
		 (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble 
					     		  (cons 1 (length (apply 'append straightened_3d_pline_point_list)))
				      )
				      (apply 'append straightened_3d_pline_point_list)
		 )
  )
  (princ)
)
__________________
K Lisp
koMon вне форума  
 
Непрочитано 11.03.2025, 10:21
#50
1958


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


Подыму тему.

Цитата:
Сообщение от VVA Посмотреть сообщение
вот по быстрому что-то сфарганил
Класс!

Цитата:
Сообщение от gette Посмотреть сообщение
Если бы еще иметь возможность захватывать близлежащие объекты (в указанном диапазоне/коридоре) и корректно наносить их на развертку, цены бы этому коду не было.
Присоединяюсь.

Ещё одно поже6лание - возможность выбора начальной и конечной точек на исходной полилинии. Чтобы развертка рисовалась не для всей линии, а в заданном диапазоне.
1958 вне форума  
 
Непрочитано 13.03.2025, 14:04
#51
1958


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


Цитата:
Сообщение от 1958 Посмотреть сообщение
Ещё одно поже6лание - возможность выбора начальной и конечной точек на исходной полилинии. Чтобы развертка рисовалась не для всей линии, а в заданном диапазоне.
Строго не судите, но что-то у меня получилось.
Правда выбираются только пересекаемые объекты.
Вложения
Тип файла: dwg
DWG 2007
Чертеж1.dwg (653.5 Кб, 10 просмотров)
Тип файла: lsp razv.lsp (7.7 Кб, 9 просмотров)
1958 вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Выравнивание полилинии в одну линию.

Опции темы Поиск в этой теме
Поиск в этой теме:

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
lisp: Длина по полилинии до точки vosh LISP 19 15.07.2013 15:10
Как получить контур полилинии с различной шириной Marina AutoCAD 5 26.12.2008 09:16
Странное выравнивание в таблице Bull AutoCAD 8 12.03.2008 12:01
Как рисуя одну полилинию получить сразу 4? Димас AutoCAD 33 22.07.2006 01:17
некорректно определяется площадь замкнутой полилинии elena_din AutoCAD 16 23.09.2005 17:37