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

f0lk · 25.03.2008, 14:55

Здравствуйте.
Есть полилиния - нужна программа которая выравнивает точки полилинии по одной прямой, со сохранением длин между вершинами полилинии.
С лиспом практически незнаком, а стандартными средствами такое сделать не получается.

VVA · 25.03.2008, 15:01

1. Полилиния LW, 2d, 3d ?
2. Есть или нет дуговые сегменты?
3. Примерчик приложи

f0lk · 25.03.2008, 15:15

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

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

Дима_ · 25.03.2008, 17:14

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

(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".

f0lk · 25.03.2008, 17:22

Дима - то что нужно!!

Огромное спасибо!

Дима_ · 25.03.2008, 17:46

Не торопись благодорить - вначале погоняй как следует.

Дима_ · 25.03.2008, 21:40

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

VVA · 26.03.2008, 10:00

Я тут тоже немного размялся

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)
  )

CB · 26.03.2008, 15:45

Аналогично (в смысле размялся )

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

Дмитррр · 21.05.2008, 09:11

А можно сделать так, что бы привязанные к узлам метки сохранялись и на разогнутой полилиние? (круги, линии, точки или блоки...)
Что-нибудь на подобие этого...

Дима_ · 21.05.2008, 12:22

Копирует так-же круги и любые блоки, НО чтоб центр (или точка вставки для блока) лежали строго на вершине полилинии.

Код:

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

(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".

VVA · 21.05.2008, 12:45

Дима_, Только я бы сравнивал координаты с допуском. У меня бывали случаи, когда 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)

Дима_ · 21.05.2008, 12:56

To VVA спасибо - я только учусь - подправил.

Profan · 21.05.2008, 13:13

Слушайте, а не послать ли эту программу в раздел "Готовые программы"? Вроде бы, тот раздел надо пополнять, но я прекратил это, когда форум caduser.ru восстановился.

Кулик Алексей aka kpblc · 21.05.2008, 13:21

Один из вариантов:

Код:

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

(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: и тишина...

f0lk · 27.05.2008, 13:48

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

Кулик Алексей aka kpblc · 27.05.2008, 14:11

Чего-чего?? ОБразец в студию!
Хотя... ближайшие два дня точно не сяду - не до того будет

Дима_ · 27.05.2008, 15:14

А выноску в блок загнать?

skkkk · 01.07.2008, 15:36

Посоветуйте пожалуйста, как поступить в моем случае. В прикрепленном чертеже желтая полилиния и ее пересекает некое кол-во полилиний других цветов. Хотелось бы выпрямить желтую так, чтобы остальные остались ее пересекать в тех же местах, т.е. на тех же расстояниях от начала желтой. Реально ли осуществить?

skkkk · 01.07.2008, 16:13

Думается, надо загнать каждую из пересекаемых линий в блок. Тогда возникает вопрос, как загнать в блок их попроще (меньшими телодвижениями)? Что-то типа нажать кнопку на панели, затем кликнуть объект - (оп!) и он уже блок (без диалоговых окон)....Может есть в КАДе стандартное решение, но я его не знаю

VVA · 01.07.2008, 16:49

Цитата:

Тогда возникает вопрос, как загнать в блок их попроще

Все выбранное в блок. Напомните ЛИСП

VVA · 01.07.2008, 17:38

Одно НО
В SETUB3 точка вставки блока посередине габарита (для отрезков - посередине), а для кода Дима_ нужно

Цитата:

НО чтоб центр (или точка вставки для блока) лежали строго на вершине полилинии

Но по моему этого не требуется в коде Алексея

skkkk · 01.07.2008, 19:17

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

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

VVA · 01.07.2008, 22:16

Не знаю, я детально не анализировал, Алексею видней всех.

Кулик Алексей aka kpblc · 01.07.2008, 23:46

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

skkkk · 02.07.2008, 02:35

Цитата:

Сообщение от Кулик Алексей aka kpblc

skkkk, #23 в продолжение #19 и на его основе?
(

именно так

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

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

Цитата:

Сообщение от Дима_

НО чтоб центр (или точка вставки для блока) лежали строго на вершине полилинии.

Цитата:

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

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

...нельзя ли этот допуск увеличить? Так, чтобы центры блоков, отстоящие от ближайшей вершины, допустим, на 0,5 единиц, тоже шли в зачет....

skkkk · 02.07.2008, 02:41

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

Дима_ · 02.07.2008, 10:27

Цитата:

Сообщение от 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 координате) - откуда сканировать сверху вниз или наоборот.

skkkk · 02.07.2008, 15:26

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

, а то я знаю, как в России рыбалка бывает

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

А по поводу справа налево. Осенило меня тут.....я сглупил конкретно, головой меня об кирпич

. Конечно же, я отрисовывал эту полилинию справа налево, а то что она рисуется наоборот, так мне же так и надо!!!! Так что этот момент переделывать ни к чему

VVA · 02.07.2008, 18:52

Ну вот по быстрому что-то сфарганил. По идее должна разворачивать все пересекающие полилинию объекты. Особо не теститровал. Поэтому лучше пока сразу выставить МСК

Код:

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

(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-х варинтах: просто развертка полилинии и развертка с пересекающими полилинию объектами)

skkkk · 02.07.2008, 19:28

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

. Рисует только прямую полилинию

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

. А можно дополнить код так, чтобы от развернутой полилинии в местах пересечения рисовались отрезки длиной 40мм по направлению вверх? Только если несложно

VVA · 02.07.2008, 22:51

Цитата:

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

Это относится только к прикрепленному чертежу из #29. Там все так. Ну этот чертеж, видимо, многое вытерпел....

Из #30

Цитата:

>Skkkk В полилинии в твоем примере из #29 есть дублирующиеся вершины. Обработай до применения RAZV3 командой PL-VxOpt и (если нужно) Entrevs.

В полилинии не должно быть дублирующихся вершин, иначе не работает выбор _fence в ssget
>skkkk #31 В местах пересечения чего с чем?

skkkk · 02.07.2008, 23:05

Цитата:

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

Из #30

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

Не заметил..

Цитата:

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

>skkkk #31 В местах пересечения чего с чем?

Вот тут во вложении красные линии. Только красными их делать не надо

skkkk · 23.07.2008, 05:00

VVA, почему-то некорректно разворачивается полилиния в примере. Длина развернутой не совпадает с длиной оригинала (при проверке entlen'ом и в свойствах). Не знаете, в чем может быть дело? Всю голову сломал. МСК стоит. Круглая часть полилинии создана обрезкой круга и присоединением pedit'ом, только на ней замечена такая ошибка. И еще не все коротенькие черточки переносит

. А еще мне неясно, почему файл так много весит?? Вроде всего две поли там, да несколько отрезков....
P.S. Речь о лиспе с #30

Gri05-1 · Регистрация: 03.04.2013

Доброго всем дня! Проьлемка в том, что есть не ровные полилинии которые нужно сделать ровными и той же длины. Лисп razv подходит, но только для горизонтальных, а если у меня вертикальные линии прога их на 90 градусов поворачивает.. В чертеже у меня они то так и должны быть, ровные верт-ые и ровные гориз-ые. Я до этого скачивал лисп - l_align_xy Александра Ривилиса, она делает все как полагается, единственно только на отрезках... Подскажите как проблему решить или ссылочку на нужный лисп киньте... А надо простые полилинии и 3д полилинии. Заранее благодарен!

skkkk · 03.04.2013, 11:46

Неточная постановка вопроса. Как неровные линии могут быть горизонтальными или вертикальными? Лучше приложить пример в dwg с нарисованными вариантами и их описанием, что есть и что надо.

sertor · 03.04.2013, 14:23

Цитата:

Сообщение от Gri05-1

а если у меня вертикальные линии прога их на 90 градусов поворачивает.

Я так понимаю, что пост написан в развитие этой темы.

skkkk · 03.04.2013, 19:11

Offtop: sertor, это она и есть "эта" тема

sertor · 03.04.2013, 20:03

Цитата:

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

sertor, это она и есть "эта" тема

Offtop: Точно. Прошу прощения за невнимательность, хотелось направить в "нужное русло".

Gri05-1 · 04.04.2013, 04:18

Прикладываю файл автокада. Не судите строго, может чего не так делаю..

gette · 24.03.2021, 04:22

Цитата:

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

Ну вот по быстрому что-то сфарганил. По идее должна разворачивать все пересекающие полилинию объекты. Особо не теститровал. Поэтому лучше пока сразу выставить МСК

Спасибо. Отлично работает, за исключением одного но - если исходная полилиния пересекает объект дважды/трижды/множество раз другой объект, то на результирующей отображается только один раз этот объект, а не в каждой точке пересечения.
Если бы еще иметь возможность захватывать близлежащие объекты (в указанном диапазоне/коридоре) и корректно наносить их на развертку, цены бы этому коду не было.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
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

25.03.2008, 14:55		#1
Выравнивание полилинии в одну линию. f0lk Регистрация: 16.10.2007 Сообщений: 7 Здравствуйте. Есть полилиния - нужна программа которая выравнивает точки полилинии по одной прямой, со сохранением длин между вершинами полилинии. С лиспом практически незнаком, а стандартными средствами такое сделать не получается.
Просмотров: 12514

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