Как уменьшить количество вершин в полилинии

Димас · 12.07.2006, 04:29

Подскажите как быстро уменьшить количество вершин у полилинии?
много полилиний вершины которой лежат на одной прямой, удалять их (вершины) в ручную - долго...
Может кто подскажет более быстрое решение?

_Andre_ · 12.07.2006, 08:47

Воспользуйтесь командой OVERKILL из Expresstools.
Она позволяет оптимизировать такие полилинии.

Кочетков Андрей · 12.07.2006, 08:53

Есть еще такие варианты:
1. Команда Weed Polyline из Тулпака или Лэнд Десктопа.
2. Команда Join из 2006-го Акада. Для этого надо предварительно эксплодить полилинию.

Profan · 12.07.2006, 09:10

Для Кочетков Андрей.
Что такое "эксплодить"? В русском языке такого слова нет. Может быть, расплодить?

Димас · 12.07.2006, 09:25

блин(( опять забыл уточнить
экспресс тулз есть, тулпаком пользоваться тоже умею)

все что советовали не подходит, работаю в ПСК, команда DSTP_PLWEED (которая Weed) не умеет работать в ПСК и выдает ошибку

может кто в курсе в 10-я версия тулпака может работать в ПСК? есть ли смысл его искать?

Димас · 12.07.2006, 09:36

не хочу чтобы у всех участвовавших вот в этой http://dwg.ru/forum/viewtopic.php?t=8509 ветке конференции создалось впечатление что получив лисп с возможностью создания вершин, создал кучу вершин и теперь пытаюсь уменьшить их количество))
просто теперь нужна помощь в "упрощении" dxf файлов с диким количеством точек))

Кочетков Андрей · 12.07.2006, 10:20

>>Димас
Каждый пользуется тем, что знает. Поэтому я бы воспользовался для этого Лэндом, чес слово! Если решишься на это - расскажу как делать

Лентяй · Регистрация: 05.01.2005

Цитата:

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

Подскажите как быстро уменьшить количество вершин у полилинии?
много полилиний вершины которой лежат на одной прямой, удалять их (вершины) в ручную - долго...
Может кто подскажет более быстрое решение?

Самый простой способ - использоавть опцию "СПРЯМИТЬ" ("STRAIGHTEN") из меню "РЕДАКТИРОВАНИЕ ВЕРШИН"("EDIT VERTEX")комады "РЕДАКТИРОВАНИ ПОЛИЛИНИИ" ("_PEDIT"). И нехрен мудрить :twisted: !

Димас · Регистрация: 31.01.2005

Цитата:

Сообщение от Лентяй

...Самый простой способ - использоавть опцию "СПРЯМИТЬ" ("STRAIGHTEN") из меню "РЕДАКТИРОВАНИЕ ВЕРШИН"("EDIT VERTEX")комады "РЕДАКТИРОВАНИ ПОЛИЛИНИИ" ("_PEDIT"). И нехрен мудрить :twisted: !

а вот приходится))
ибо работаю не один и есть люди которым автокад очень сложен, вот для них и нужен лисп вершины убивать
а то ну очень меня нервирует по 10 раз в день объяснять как добавить вершину, как ее убрать и почему убрались вершины с другой полилинии и т.д.
спасите мои нервы!))) дайте пожалуйста лисп убивающий вершины)
to Кочетков Андрей
лендом пользовался но вот так сразу не могу придумать как убить лишние вершины, может в двух словах объясните?

Кочетков Андрей · 13.07.2006, 09:09

Сначала конвертируем двухмерные линии в трехмерные (потому что последующие команды Лэнда не работают с 2д линиями). Это можно сделать либо с помощью Лэнда (см. картинку), либо с помощью Тулпака. Я предпочитаю Тулпак, но принципиальной разницы нет.
Затем импользуем команду Weed Vertices из Лэнда (см. картинку).
Для "максимально минимального" искажения линий, угол надо выставить именно таким, а вот с длиной поиграйся - тут нет общих рекомендаций.
Ну и наконец, если необходимо, преобразуй 3д линии в 2д, опять же с помощью либо Тулпака, либо Лэнда.
[ATTACH]1152767351.jpg[/ATTACH]

Димас · 13.07.2006, 09:41

ага, с лендом понятно))
мне по другому будет тогда проще делать - копировать в новый файл(COPY, Paste to orig..), там тулпаком уменьшать к-во вершин, и обратно копировать уже с меньшим к-вом вершиин
так мне не нужно будет на машины ленд ставить)
но за совет спасибо)

VVA · 14.07.2006, 04:04

Попробуй эту команду для LWPOLYLINE

Код:

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

(defun C:PLVXDEL ( / lw adoc *error* )
(defun *error* (message)
  (princ message)(vla-endundomark adoc)(princ))
  
(defun lwplvxdel (lw / pln ed pvx cvx item)
  (setq ed (entget lw))
  (while ed
    (setq item (car ed)
	  ed   (cdr ed))
    (cond
      ((= (car item) 10)
       (setq cvx (list item
		       (assoc 40 ed)
		       (assoc 41 ed)
		       (assoc 42 ed))
	     ed	 (cdddr ed))
       (if pvx
	 (progn
	   (setq cang (angle (cdr (assoc 10 pvx))
			     (cdr (assoc 10 cvx))))
	   (cond
	     ((not (zerop (cdr (assoc 42 pvx))))
	      (setq pln	 (append pln pvx cvx)
		    pang nil))
	     ((zerop (cdr (assoc 42 pvx)))
	      (cond
		((null pang)
		 (setq pang cang))
		((not (equal pang cang 0.01))
		 (setq pln  (append pln pvx)
		       pang cang))
		(t nil)) ;_cond
	     )
	   ) ;_cond
	   (setq pvx cvx)
	 )
	 (setq pvx cvx
	       pln (append pln pvx)
	 )
       ) ;_if pvx
      )
      (t (setq pln (append pln (list item))))
    ) ;_cond
  );_while
  (setq pln (append pln cvx))
  (setq	pln (subst (cons 90 (length (lib:massoc 10 pln)))
		   (assoc 90 pln)
		   pln ))
  (entmod pln)
  (entupd lw)
)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark adoc)	
    (setq lw (car (entsel "\nВыберите полилинию:")))
    (if (and lw
	     (= (cdr(assoc 0 (entget lw))) "LWPOLYLINE"))
      (lwplvxdel lw)
      (alert "\nНичего не выбрано\nили объект не LWPOLYLINE"))
  (vla-endundomark adoc)	
(princ))
(princ "\nНаберите PLVXDEL")

Димас · 14.07.2006, 06:35

выдает ошибку:

Код:

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

Command:  PLVXDEL
Âûáåðèòå ïîëèëèíèþ:no function definition: LIB:MASSOC

VVA · 14.07.2006, 14:05

Вечно забываю библиотечные ф-ции
Лови

Код:

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

;|  ! ***************************************************************************
;; !                           lib:massoc
;; ! ***************************************************************************
;; ! Function : Utility function to get multiple group code
                Возвращает все вхождения ключа в списке
;; ! Argument : 'key'     - The DXF code to check / DXF код
;; !            'alist' -    The List to check  / Список
;; ! Returns  : The value of the DXF dotted pair, if it exists else returns nil
                Значение точечной пары, если есть или nil
;; ! ****************************************************************************|;
;;; Utility function to get multiple group code CDRs
(defun lib:massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
    )
  )
  (reverse nlist)
)

VVA · 15.07.2006, 02:04

Вот вариант программы, работающий со всеми (надеюсь) полилиниями

Код:

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

;;;Удаление вершин полилиний, которые лежат на одной прямой
(defun C:PLVXREDUCE ( / lw adoc *error* l )
(defun *error* (message)
  (princ message)(vla-endundomark adoc)(princ))
  (defun lib:massoc (key alist / x nlist)
  (foreach x alist
   (if (eq key (car x))(setq nlist (cons (cdr x) nlist))))
  (reverse nlist))
    (defun rec_lst_3d (lst)
    (if lst
      (cons (list  (car lst)(cadr lst)(caddr lst))
	    (rec_lst_3d (cdddr lst))))
    ) ;_  defun
  (defun rem-3d-pl (lst) 
 (cond ((not lst) nil) 
       ((and (cdr lst)
	  (equal (angle (car lst) (cadr lst)) pang 1e-6)) 
           (rem-3d-pl (cdr lst)))
       ((and (cdr lst)
	  (not(equal (angle (car lst) (cadr lst)) pang 1e-6)))
	  (setq pang (angle (car lst) (cadr lst)))
           (cons (car lst) (rem-3d-pl (cdr lst))))
       
       (t (cons (car lst) (rem-3d-pl (cdr lst))))) ;_  cond 
) ;_  defun 
(defun pl3d2dvxdel (lw / vx lst pang l cv)
(setq vx (rec_lst_3d (vlax-get lw 'coordinates))
     lst (cdr vx)
    pang (angle (car vx)(cadr vx))
       l (rem-3d-pl lst)
       l (append (list (car vx)) l)
      cv (- (length vx)(length l))
       l (apply 'append l))
 (vla-put-coordinates lw (vlax-make-variant (vlax-safearray-fill 
                     (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l)))
  (princ "\nУдалено ")(princ cv)(princ " вершин")
  )
(defun lwplvxdel (lw / pln ed pvx cvx item cv)
  (setq ed (entget lw) cv 0)
  (while ed
    (setq item (car ed)
	  ed   (cdr ed))
    (cond
      ((= (car item) 10)
       (setq cvx (list item (assoc 40 ed)(assoc 41 ed)(assoc 42 ed))
	     ed	 (cdddr ed))
       (if pvx
	 (progn
	   (setq cang (angle (cdr (assoc 10 pvx))
			     (cdr (assoc 10 cvx))))
	   (cond
	     ((not (zerop (cdr (assoc 42 pvx))))
	      (setq pln	 (append pln pvx cvx) pang nil))
	     ((zerop (cdr (assoc 42 pvx)))
	      (cond
		((null pang)(setq pang cang))
		((not (equal pang cang 0.01))
		 (setq pln  (append pln pvx) pang cang))
		(t (setq cv (1+ cv)))))) ;_cond
	   (setq pvx cvx))
	 (setq pvx cvx pln (append pln pvx))) ;_if pvx
      )
      (t (setq pln (append pln (list item))))) ;_cond
  );_while
  (setq pln (append pln cvx))
  (setq	pln (subst (cons 90 (length (lib:massoc 10 pln)))
		   (assoc 90 pln)
		   pln ))
  (princ "\nУдалено ")(princ cv)(princ " вершин")
  (entmod pln)(entupd lw)
)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark adoc)

  (vla-getEntity (vla-get-utility adoc) 
    'lw 'nil "\nSelect any Polyline: ")
  (cond
    ((member (vla-get-ObjectName lw) '("AcDb3dPolyline" "AcDb2dPolyline"))
     (pl3d2dvxdel lw))
    ((= (vla-get-ObjectName lw) "AcDbPolyline")
	 (lwplvxdel (vlax-vla-object->ename lw)))
    (t (princ "\nВы не выбрали  полилинию")))
  (vla-endundomark adoc)	
(princ))
(princ "\nНаберите PLVXREDUCE")

Лентяй · 15.07.2006, 08:45

Скажите, VVA, ну почему у вас такая классовая ненависть к "легким полилиниям"? Почему вы их посточнно отлучаете от всех прочих? Посмотрите, как просто и изящно вы могли бы сделать вашу программу, если бы не были таким непримирмым:

Код:

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

(defun C:PLVXREDUCE ( / lw adoc *error* l ) 
(defun *error* (message) 
  (princ message)(vla-endundomark adoc)(princ)) 
  (defun lib:massoc (key alist / x nlist) 
  (foreach x alist 
   (if (eq key (car x))(setq nlist (cons (cdr x) nlist)))) 
  (reverse nlist))
  (defun rec_lst (lst)
    (if lst (cond ((= (vla-get-ObjectName lw) "AcDb3dPolyline")
                   (cons (list (car lst)(cadr lst)(caddr lst)) (rec_lst (cdddr lst))))
                  ((= (vla-get-ObjectName lw) "AcDbPolyline")
                   (cons (list (car lst)(cadr lst)) (rec_lst (cddr lst))))));if
  );defun
  (defun rem-pl (lst / ang)
    (cond ((not lst) nil)
          ((cdr lst)
           (setq n (1- (length lst))
                 ang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam lw x))
                               (list n (1- n)))))
           (if (equal ang pang 1e-6) (rem-pl (cdr lst))
             (progn (setq pang ang)
               (cons (car lst) (rem-pl (cdr lst))))))
          (t (cons (car lst) (rem-pl (cdr lst)))));cond
  );rem-pl
  (defun plvxdel (lw / vx lst pang l cv)
    (setq vx (rec_lst (vlax-get lw 'coordinates))
          n (1- (vlax-curve-getEndParam lw))
          lst (cdr vx)
          pang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam lw x))
                               (list (1+ n) n)))
          l (append (list (car vx)) (rem-pl lst))
          cv (- (length vx) (length l))
          l (apply 'append l));setq
    (vla-put-coordinates lw (vlax-make-variant (vlax-safearray-fill 
                     (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l)))
    (princ "\nУдалено ")(princ cv)(princ " вершин")
  );plvxdel
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark adoc)
  (if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
             (vla-getEntity (vla-get-utility adoc) 'lw 'nil "\nSelect any Polyline: ")))))
    (if (wcmatch (vla-get-ObjectName lw) "*Polyline")
      (plvxdel lw)
      (alert "It's Not a Polyline!!"));if
    (alert "Nothing Selected!!"));if 
  (vla-endundomark adoc)    
(princ)) 
(princ "\nНаберите PLVXREDUСЕ")

Заметьте, я опять практически ничего не поменял, только применил функцию вычисления угла - общую для всех типов плилиний.

aldt · 15.07.2006, 10:31

Лентяй
посмотрите еще раз тест.
почему то не удаляется вторая вершина.
и можно ли ввести допуск на отклонение от прямой.
[ATTACH]1152945102.rar[/ATTACH]

VVA · 15.07.2006, 20:36

>Лентяй Похоже, что у "легких полилиниях" классовая ненависть ко мне. Опять Актовад выдает

Цитата:

Команда: ; ошибка: Возникло исключение: 0xC0000005 (Нарушение доступа)
; предупреждение: раскрутка пропущена для неверное исключение

Автокад 2006 Русский. Может в нем дело?
>aldt Пока что свой вариант прогаммы ввиду вышесказанного.

Код:

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

;;;Удаление вершин полилиний, которые лежат на одной прямой
(defun C:PLVXREDUCE ( / lw adoc *error* l nev )
(defun *error* (message)
  (princ message)(vla-endundomark adoc)(princ))
    (defun rec_lst_3d (lst)
    (if lst
      (cons (list  (car lst)(cadr lst)(caddr lst))
	    (rec_lst_3d (cdddr lst))))
    ) ;_  defun
  (defun rem-3d-pl (lst) 
 (cond ((not lst) nil) 
       ((and (cdr lst)
	  (equal pang (angle (car lst) (cadr lst)) nev)) 
           (rem-3d-pl (cdr lst)))
       ((and (cdr lst)
	  (not(equal pang (angle (car lst) (cadr lst)) nev)))
	  (setq pang (angle (car lst) (cadr lst)))
           (cons (car lst) (rem-3d-pl (cdr lst))))
       (t (cons (car lst) (rem-3d-pl (cdr lst))))) ;_  cond 
) ;_  defun 
(defun pl3d2dvxdel (lw / vx lst pang l cv)
(setq vx (rec_lst_3d (vlax-get lw 'coordinates))
     lst (cdr vx)
    pang (angle (car vx)(cadr vx))
       l (rem-3d-pl lst)
       l (append (list (car vx)) l)
      cv (- (length vx)(length l))
       l (apply 'append l))
 (vla-put-coordinates lw (vlax-make-variant (vlax-safearray-fill 
                     (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l)))
  (princ "\nУдалено ")(princ cv)(princ " вершин")
  )
(defun lwplvxdel (lw / pln ed pvx cvx item cv)
  (setq ed (entget lw) cv 0)
  (while ed
    (setq item (car ed)
	  ed   (cdr ed))
    (cond
      ((= (car item) 10)
       (setq cvx (list item (assoc 40 ed)(assoc 41 ed)(assoc 42 ed))
	     ed	 (cdddr ed))
       (if pvx
	 (progn
	   (setq cang (angle (cdr (assoc 10 pvx))
			     (cdr (assoc 10 cvx))))
	   (cond
	     ((not (zerop (cdr (assoc 42 pvx))))
	      (setq pln	 (append pln pvx cvx) pang nil))
	     ((zerop (cdr (assoc 42 pvx)))
	      (cond
		((null pang)(setq pang cang))
		((not (equal pang cang nev))
		 (setq pln  (append pln pvx) pang cang))
		(t (setq cv (1+ cv)))))) ;_cond
	   (setq pvx cvx))
	 (setq pvx cvx pln (append pln pvx))) ;_if pvx
      )
      (t (setq pln (append pln (list item))))) ;_cond
  );_while
  (setq pln (append pln cvx))
  (setq	pln (subst (cons 90
			 (length (VL-REMOVE-IF-NOT
				   '(lambda (x)(= (car x) 10))
				   pln)))
		   (assoc 90 pln)
		   pln ))
  (princ "\nУдалено ")(princ cv)(princ " вершин")
  (entmod pln)(entupd lw)
)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark adoc)
  (initget 6)
  (if (null (setq nev (getangle "\nУгол невязки в градусах <1>:")))
    (setq nev 0.0174533))
  (vla-getEntity (vla-get-utility adoc) 
    'lw 'nil "\nSelect any Polyline: ")
  (cond
    ((member (vla-get-ObjectName lw) '("AcDb3dPolyline" "AcDb2dPolyline"))
     (pl3d2dvxdel lw))
    ((= (vla-get-ObjectName lw) "AcDbPolyline")
	 (lwplvxdel (vlax-vla-object->ename lw)))
    (t (princ "\nВы не выбрали  полилинию")))
  (vla-endundomark adoc)	
(princ))
(princ "\nНаберите PLVXREDUCE")

В твоем чертеже для наклонной полилинии вершины спрямились с невязкой в 2 градуса
Если код Лентяя работает, то замени в

Код:

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

(equal ang pang 1e-6)

1e-6 на значение нужного угла в радианах
Так же вершина может не спрямится, если она "переходит" через 0.
Т.е. при навравлении 1 и 359 градусов с невязкой в 2 программа не удалит вершину (хотя должна). Но пока не придумал алгоритм проверки. Как вариант выхода -> повернуть плинию на некий угол, а потом вернуть обратно.

aldt · 15.07.2006, 20:56

VVA
спасибо!
попробую разобраться.

Димас · 17.07.2006, 02:26

to VVA
Спасибо буду пробовать)

Лентяй · 18.07.2006, 01:35

Цитата:

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

>Лентяй Похоже, что у "легких полилиниях" классовая ненависть ко мне. Опять Актовад выдает

Цитата:

Команда: ; ошибка: Возникло исключение: 0xC0000005 (Нарушение доступа)
; предупреждение: раскрутка пропущена для неверное исключение

Автокад 2006 Русский. Может в нем дело?

АвтоКАД здесь не при чем. А полилинии вас не любят за вашу нездоровую симпатию к рекурсиям. Если плиинию перерисовывать каждый раз после удаления очередной вершины, то все получается. [sm200]

Код:

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

(defun C:PlVxRdc ( / lw adoc *error* l vx lst pang ls l var)
  (vl-load-com)
  (defun *error* (message)
    (princ message)(vla-endundomark adoc)(princ)
  );defun
  (defun rec_lst (lst)
    (if lst (cond ((= (vla-get-ObjectName lw) "AcDb3dPolyline")
                   (cons (list (car lst)(cadr lst)(caddr lst)) (rec_lst (cdddr lst))))
                  ((= (vla-get-ObjectName lw) "AcDbPolyline")
                   (cons (list (car lst)(cadr lst)) (rec_lst (cddr lst))))));if
  );defun
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark adoc)
  (if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
             (vla-getEntity (vla-get-utility adoc) 'lw 'nil "\nВыбери Полилинию: ")))))
    (if (wcmatch (vla-get-ObjectName lw) "*Polyline")
      (progn
        (setq vx (rec_lst (vlax-get lw 'coordinates))
              n (1- (fix (vlax-curve-getEndParam lw)))
              lst (cdr vx)
              pang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam lw x))
                                   (list (1+ n) n))));setq
        (while (< 0 n)
          (setq ang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam lw x))
                               (list n (1- n)))))
          (if (equal ang pang 1e-6) (progn
               (setq lst (vl-remove (nth (1- n) lst) lst)
                     ls (append (list (car vx)) lst)
                     l (apply 'append ls)
                     var (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble
                                     (cons 0 (1- (length l)))) l)));setq
               (vla-put-coordinates lw var));progn
            (setq pang ang));if
          (setq n (1- n)));while
        (print (strcat "\nУдалено " (itoa (- (length vx) (length ls))) " вершин")));progn
      (alert "Это не полилиня!!"));if
    (alert "Ни фига не выбрано!!"));if
  (vla-endundomark adoc)    
(princ)) 
(princ "\nНаберите PlVxRdc")

Ну, и специально для Димаса и прочих любителей всего помногу.

Код:

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

(defun C:PlVxRdc ( / pl adoc *error* vx lst pang ls l)
  (vl-load-com)
  (defun *error* (message)
    (princ message)(vla-endundomark adoc)(princ)
  );defun
  (defun rec_lst (lst)
    (if lst (cond ((= (vla-get-ObjectName pl) "AcDb3dPolyline")
                   (cons (list (car lst)(cadr lst)(caddr lst)) (rec_lst (cdddr lst))))
                  ((= (vla-get-ObjectName pl) "AcDbPolyline")
                   (cons (list (car lst)(cadr lst)) (rec_lst (cddr lst))))));if
  );defun
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        ass (vla-get-ActiveSelectionSet adoc) m 0)
  (if (< 0 (vla-get-count ass)) (vla-clear ass))
  (vla-startundomark adoc)
  (vla-SelectOnScreen ass (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list "*Polyline")))
  (vla-InitializeUserInput util 4)
  (setq tol (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
               (setq tol (vla-getReal util "Enter Angular Tolerance or <ENTER> for 0 : ")))))
              1e-4 tol))
  (if (< 0 (vla-get-count ass))
    (vlax-for pl ass
      (setq vx (rec_lst (vlax-get pl 'coordinates))
            n (1- (fix (vlax-curve-getEndParam pl)))
            lst (cdr vx)
            pang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam pl x))
                               (list (1+ n) n)))
            m (1+ m));setq
      (while (< 0 n)
        (setq ang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam pl x))
                               (list n (1- n)))))
        (if (equal ang pang (* (/ tol 180) pi)) (progn
            (setq lst (vl-remove (nth (1- n) lst) lst)
                  ls (append (list (car vx)) lst)
                  l (apply 'append ls));setq
            (vla-put-coordinates pl (vlax-make-variant (vlax-safearray-fill
               (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l))));progn
          (setq pang ang));if
        (setq n (1- n)));while
      (print (strcat "Poliline " (itoa m) " Purged: "
             (itoa (- (length vx) (length ls))) " Vertex(es) Removed with "
               (rtos tol 2) "-deg. Tolerance.")));vlax-for
    (alert "Nothing Selected!!"));if
  (vla-endundomark adoc)
  (princ))
(princ "\nEnter PlVxRdc")

Пользуйтесь на здоровье, и не забывайте денно и нощно сугубо и трегубо благодарить меня за то, что я у вас есть.

VVA · 18.07.2006, 12:24

Лентяй, браво [sm204] .Однако я уже писал и еще раз повторю, что Лентяй оправдывает свой ник и к его кодам надо подходить (подползать с благоговением и трепетом) творчески. В данном случае не получен указатель на объект util + много глобальных переменных.
Вот подправленный вариант

Код:

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

(defun C:PlVxRdc ( / pl adoc *error* vx lst pang ls l ass m n  tol ang util) 
  (vl-load-com) 
  (defun *error* (message) 
    (princ message)(vla-endundomark adoc)(princ) 
  );defun 
  (defun rec_lst (lst) 
    (if lst (cond ((member (vla-get-ObjectName pl) '("AcDb3dPolyline" "AcDb2dPolyline")) 
                   (cons (list (car lst)(cadr lst)(caddr lst)) (rec_lst (cdddr lst)))) 
                  ((= (vla-get-ObjectName pl) "AcDbPolyline") 
                   (cons (list (car lst)(cadr lst)) (rec_lst (cddr lst))))));if 
  );defun 
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)) 
        ass (vla-get-ActiveSelectionSet adoc) m 0
	util (vla-get-Utility adoc)) 
  (if (< 0 (vla-get-count ass)) (vla-clear ass)) 
  (vla-startundomark adoc) 
  (vla-SelectOnScreen ass (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list "*Polyline"))) 
  (vla-InitializeUserInput util 4) 
  (setq tol (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda () 
               (setq tol (vla-getReal util "Enter Angular Tolerance or <ENTER> for 0 : "))))) 
              1e-4 tol)) 
  (if (< 0 (vla-get-count ass)) 
    (vlax-for pl ass 
      (setq vx (rec_lst (vlax-get pl 'coordinates)) 
            n (1- (fix (vlax-curve-getEndParam pl))) 
            lst (cdr vx) 
            pang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam pl x)) 
                               (list (1+ n) n))) 
            m (1+ m));setq 
      (while (< 0 n) 
        (setq ang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam pl x)) 
                               (list n (1- n))))) 
        (if (equal ang pang (* (/ tol 180) pi)) (progn 
            (setq lst (vl-remove (nth (1- n) lst) lst) 
                  ls (append (list (car vx)) lst) 
                  l (apply 'append ls));setq 
            (vla-put-coordinates pl (vlax-make-variant (vlax-safearray-fill 
               (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l))));progn 
          (setq pang ang));if 
        (setq n (1- n)));while 
      (print (strcat "Poliline " (itoa m) " Purged: " 
             (itoa (- (length vx) (length ls))) " Vertex(es) Removed with " 
               (rtos tol 2) "-deg. Tolerance.")));vlax-for 
    (alert "Nothing Selected!!"));if 
  (vla-endundomark adoc) 
  (princ)) 
(princ "\nEnter PlVxRdc")

Однако код требует доработки, т.к. не учитывает дуговые сегменты. Если он есть и перед ним удалилось n вершин, то этот сегмент спрямится, а дуговым станет n-й сегмент после него

VVA · 18.07.2006, 15:34

Вот вариант с обработкой дуговых сегментов

Код:

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

(defun C:PlVxRdc ( / pl adoc *error* vx lst pang ls l ass m n  tol ang util blglist i) 
  (vl-load-com) 
  (defun *error* (message) 
    (princ message)(vla-endundomark adoc)(princ) 
  );defun
 ;;;Ф-ция изменяет i-й(начиная с 0) элемент списка новым значением
;;; indel - индекс элемента
;;;zn - значение
;;; sps - список
(defun subst-i (indel zn sps / buff i e1)
  (setq	i 0 buff nil) ;_ End of setq
  (foreach e1 sps
    (if	(= i indel)
      (setq buff (append buff (list zn)))
      (setq buff (append buff (list e1)))) ;_ End of if
    (setq i (1+ i))) ;_ End of foreach
  buff) ;_ End of defun
  (defun rec_lst (lst) 
    (if lst (cond ((member (vla-get-ObjectName pl) '("AcDb3dPolyline" "AcDb2dPolyline")) 
                   (cons (list (car lst)(cadr lst)(caddr lst)) (rec_lst (cdddr lst)))) 
                  ((= (vla-get-ObjectName pl) "AcDbPolyline") 
                   (cons (list (car lst)(cadr lst)) (rec_lst (cddr lst))))));if 
  );defun 
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)) 
        ass (vla-get-ActiveSelectionSet adoc) m 0
	util (vla-get-Utility adoc)) 
  (if (< 0 (vla-get-count ass)) (vla-clear ass)) 
  (vla-startundomark adoc) 
  (vla-SelectOnScreen ass (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list "*Polyline"))) 
  (vla-InitializeUserInput util 4) 
  (setq tol (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda () 
               (setq tol (vla-getReal util "Enter Angular Tolerance or <ENTER> for 0 : "))))) 
              1e-4 tol)) 
  (if (< 0 (vla-get-count ass)) 
    (vlax-for pl ass 
      (setq vx (rec_lst (vlax-get pl 'coordinates)) 
            n (1- (fix (vlax-curve-getEndParam pl))) 
            lst (cdr vx) 
            pang (if (or (and (vlax-method-applicable-p pl 'Getbulge) ;_Сегменты могут быть дуговыми
			  (not (zerop (vla-GetBulge pl n))))      ;_Дуговой сегмент
			 (not (vlax-method-applicable-p pl 'Getbulge))) ;_Сегменты не могут быть дуговыми
		   (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam pl x)) 
                               (list (1+ n) n)))
		   nil);_if
            m (1+ m));setq
      (setq blglist nil i 0)
      (while (and (vlax-method-applicable-p pl 'Getbulge)(< i (fix (vlax-curve-getEndParam pl))))
	(setq blglist (append blglist (list (vla-GetBulge pl i))) i (1+ i)));_while
      (while (< 0 n)
       (setq ang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam pl x)) 
                           (list n (1- n))))) 
	(if (null pang)
	  (setq pang ang);_Предыдущий сегмент был дуговым, посмотрим что будет дальше
	(if (or (and (vlax-method-applicable-p pl 'Getbulge) ;_Сегменты могут быть дуговыми
		     (zerop (vla-GetBulge pl n)))      ;_Линейный сегмент
	        (not (vlax-method-applicable-p pl 'Getbulge))) ;_Сегменты не могут быть дуговыми
	(progn ;_Короче, здесь линейный сегмент  
        (if (equal ang pang (* (/ tol 180) pi)) (progn 
            (setq lst (vl-remove (nth (1- n) lst) lst) 
                  ls (append (list (car vx)) lst) 
                  l (apply 'append ls));setq 
            (vla-put-coordinates pl (vlax-make-variant (vlax-safearray-fill 
               (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l)))
	    ;;;Удаляем n вершину заменяем n bulge на nil
	    (if blglist (setq blglist (subst-i  n nil blglist)))
	    );progn 
          (setq pang ang));if
	);_progn
	 (setq pang nil) ;_Дуговой сегмент
	  );_if or
	  )
        (setq n (1- n)));while
      ;;;Восстанавливаем bulge
      (setq i 0)
      (if (vlax-method-applicable-p pl 'Setbulge)
	(mapcar '(lambda (blg)(if blg (progn (vla-SetBulge pl i blg)(setq i (1+ i))))) blglist))
      (print (strcat "Poliline " (itoa m) " Purged: " 
             (itoa (- (length vx) (length ls))) " Vertex(es) Removed with " 
               (rtos tol 2) "-deg. Tolerance.")));vlax-for 
    (alert "Nothing Selected!!"));if 
  (vla-endundomark adoc) 
  (princ)) 
(princ "\nEnter PlVxRdc")

VVA · 18.07.2006, 16:19

Надеюсь последний вариант. Обрабатывает еще и сглаженные полилинии (вернее игнорирует их)

Код:

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

(defun C:PlVxRdc ( / pl adoc *error* vx lst pang ls l ass m n  tol ang util blglist i) 
  (vl-load-com) 
  (defun *error* (message)(princ message)(vla-endundomark adoc)(princ))
;;;Ф-ция изменяет i-й(начиная с 0) элемент списка новым значением
;;; indel - индекс элемента zn - значение  sps - список
(defun subst-i (indel zn sps / buff i e1)
  (setq	i 0 buff nil) ;_ End of setq
  (foreach e1 sps
    (if	(= i indel)
      (setq buff (append buff (list zn)))
      (setq buff (append buff (list e1)))) ;_ End of if
    (setq i (1+ i))) ;_ End of foreach
  buff) ;_ End of defun
  (defun rec_lst (lst) 
    (if lst (cond ((member (vla-get-ObjectName pl) '("AcDb3dPolyline" "AcDb2dPolyline")) 
                   (cons (list (car lst)(cadr lst)(caddr lst)) (rec_lst (cdddr lst)))) 
                  ((= (vla-get-ObjectName pl) "AcDbPolyline") 
                   (cons (list (car lst)(cadr lst)) (rec_lst (cddr lst))))));if 
  );defun 
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)) 
        ass (vla-get-ActiveSelectionSet adoc) m 0
	util (vla-get-Utility adoc)) 
  (if (< 0 (vla-get-count ass)) (vla-clear ass)) 
  (vla-startundomark adoc) 
  (vla-SelectOnScreen ass (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list "*Polyline"))) 
  (vla-InitializeUserInput util 4) 
  (setq tol (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda () 
               (setq tol (vla-getReal util "Enter Angular Tolerance or <ENTER> for 0 : "))))) 
              1e-4 tol)) 
  (if (< 0 (vla-get-count ass)) 
    (vlax-for pl ass
      (if (and(vlax-property-available-p pl "Type")
	      (not (zerop(vla-get-type pl))))
	(setq n 0 vx nil) ;_Какая-то сглаженная полилиния
	(setq vx (rec_lst (vlax-get pl 'coordinates))
	      n (1- (fix (vlax-curve-getEndParam pl)))))
      (setq lst (cdr vx) 
            pang (if (or (and vx
			  (vlax-method-applicable-p pl 'Getbulge) ;_Сегменты могут быть дуговыми
			  (not (zerop (vla-GetBulge pl n))))      ;_Дуговой сегмент
			 (not (vlax-method-applicable-p pl 'Getbulge))) ;_Сегменты не могут быть дуговыми
		   (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam pl x)) 
                               (list (1+ n) n)))
		   nil);_if
            m (1+ m));setq
      (setq blglist nil i 0)
      (while (and vx (vlax-method-applicable-p pl 'Getbulge)(< i (fix (vlax-curve-getEndParam pl))))
	(setq blglist (append blglist (list (vla-GetBulge pl i))) i (1+ i)));_while
      (while (< 0 n)
       (setq ang (apply 'angle (mapcar '(lambda (x) (vlax-curve-getPointAtParam pl x)) 
                           (list n (1- n))))) 
	(if (null pang)
	  (setq pang ang);_Предыдущий сегмент был дуговым, посмотрим что будет дальше
	(if (or (and (vlax-method-applicable-p pl 'Getbulge) ;_Сегменты могут быть дуговыми
		     (zerop (vla-GetBulge pl n)))      ;_Линейный сегмент
	        (not (vlax-method-applicable-p pl 'Getbulge))) ;_Сегменты не могут быть дуговыми
	(progn ;_Короче, здесь линейный сегмент  
        (if (equal ang pang (* (/ tol 180) pi)) (progn 
            (setq lst (vl-remove (nth (1- n) lst) lst) 
                  ls (append (list (car vx)) lst) 
                  l (apply 'append ls));setq 
            (vla-put-coordinates pl (vlax-make-variant (vlax-safearray-fill 
               (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l)))
	    ;;;Удаляем n вершину заменяем n bulge на nil
	    (if blglist (setq blglist (subst-i  n nil blglist)))
	    );progn 
          (setq pang ang));if
	);_progn
	 (setq pang nil) ;_Дуговой сегмент
	  );_if or
	  )
        (setq n (1- n)));while
      ;;;Восстанавливаем bulge
      (setq i 0)
      (if (vlax-method-applicable-p pl 'Setbulge)
	(mapcar '(lambda (blg)(if blg (progn (vla-SetBulge pl i blg)(setq i (1+ i))))) blglist))
      (print (strcat "Poliline " (itoa m) " Purged: " 
             (itoa (- (length vx) (length ls))) " Vertex(es) Removed with " 
               (rtos tol 2) "-deg. Tolerance.")));vlax-for 
    (alert "Nothing Selected!!"));if 
  (vla-endundomark adoc) 
  (princ)) 
(princ "\nEnter PlVxRdc")

Лентяй · 18.07.2006, 22:22

Уважаемый VVA. ваше стремление довести все до совершенства весьма похвально, но ваше усердие иногда служит вам плохую службу. В частности, вы включаете сплайны ("сглаженные полилинии", AcDb2dPolyline) в список обрабатываемых обектов, а затем изощряетесь их игнорировать. Не проще ли отбросить их сразу - на стадии первичной обработки списка координат, например так:

Код:

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

(defun rec_lst (lst)
    (if lst (cond ((= (vla-get-ObjectName pl) "AcDb3dPolyline")
                   (cons (list (car lst)(cadr lst)(caddr lst)) (rec_lst (cdddr lst))))
                  ((= (vla-get-ObjectName pl) "AcDbPolyline")
                   (cons (list (car lst)(cadr lst)) (rec_lst (cddr lst))))
                  ((= (vla-get-ObjectName pl) "AcDb2dPolyline")
                   (alert "No Spline Treatment!!") (exit))));if
  );defun

И тогда не надо будет измышлять условия типа, "то ли есть BULGE, то ли нет"

.
Да, и еще, коль скоро уже vx определено и обработано, надо ли каждый раз проверять его существование? Подумайте, и, может быть, все станет немного проще.

Димас · 19.07.2006, 02:40

спасибо всем огромное за написание стольких разных версий кода))
теперь прям не знаю которым лучше пользоваться)
работают все программы

VVA · 19.07.2006, 11:11

>Лентяй У 99.999% пользователей скорее всего так и будет, при plinetype=2 AcDb2dPolyline-это только "сглаженная полилиния".
У нас есть arx, который создает не сглаженные AcDb2dPolyline, и явно не командой _PLINE :twisted: . Поэтому либо _convert после каждой этой команды, либо учитывать, что может быть не сглаженная AcDb2dPolyline.
Когда есть алгоритм, стараешься вписаться в него.
(exit) - не пойдет, мы ведь в цикле по набору. Надо его отработать до конца.
(setq n 0 vx nil) - искусственный прием, просто все последующие проверки не отработают для сглаженной полилинии.

Osbend · 01.01.2014, 18:37

Чтобы не создавать новой темы. Нужно значительно уменьшить количество вершин без ущерба чертежу. Очень нужна помощь, от этого зависит карьера. Чертёж выполнен в программе Rhino сторонней фирмой-клиентом, Autocad-ом они не пользуются. Нам нужно изготовить деталь, но машина не принимает чертежи такой сложности. Нужен способ упростить. Заранее спасибо.

sertor · 01.01.2014, 18:54

Osbend, можно использовать пакет программ Pltools.

Osbend · 01.01.2014, 19:59

Не вижу разницы, по-прежнему множество вершин.

sertor · 01.01.2014, 21:53

Osbend, ну так Вы "поиграйте" с max значением отклонения от прямой (по умолчанию - 0.15). При этом, главное - не переусердствовать. Иначе линии станут угловатыми (исчезнет плавность).

12.07.2006, 04:29		#1
Как уменьшить количество вершин в полилинии Димас джедай Магадан Регистрация: 31.01.2005 Сообщений: 460 Подскажите как быстро уменьшить количество вершин у полилинии? много полилиний вершины которой лежат на одной прямой, удалять их (вершины) в ручную - долго... Может кто подскажет более быстрое решение?
Просмотров: 42208