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

Димас · 12.07.2006, 04:29

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

Лентяй · 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
Как уменьшить количество вершин в полилинии Димас джедай Магадан Регистрация: 31.01.2005 Сообщений: 460 Подскажите как быстро уменьшить количество вершин у полилинии? много полилиний вершины которой лежат на одной прямой, удалять их (вершины) в ручную - долго... Может кто подскажет более быстрое решение?
Просмотров: 42189