Удаление совпадающих вершин из полилинии

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

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

X-DeViL · 13.07.2006, 10:37

А в СКАДе есть такая кнопочка

но... к сожалению CTRL+c она не переносится

Елпанов Евгений · Регистрация: 20.12.2005

Цитата:

Сообщение от Кочетков Андрей

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

Набросал по быстрому - безо всяких проверок...

Код:

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

(defun rec_lst_3d (lst)
 (if lst
  (cons
   (list
    (car lst)
    (cadr lst)
    (caddr lst)
   ) ;_  list
   (rec_lst_3d (cdddr lst))
  ) ;_  cons
 ) ;_  if
) ;_  defun
(defun rec-rem-dubl (lst)
 (cond ((not lst) nil)
       ((and (cdr lst) (equal (car lst) (cadr lst) 1e-6))
	(rec-rem-dubl (cdr lst))
       )
       (t (cons (car lst) (rec-rem-dubl (cdr lst))))
 ) ;_  cond
) ;_  defun
(defun c:plopt (/ l x)
 (prompt "\nSelect 3d Polyline: ")
 (if (setq x (ssget "_+.:E:S" '((100 . "AcDb3dPolyline"))))
  (progn
   (setq x (vlax-ename->vla-object
	    (ssname x 0)
	   ) ;_  vlax-ename->vla-object
	 l (apply
	    'append
	    (rec-rem-dubl
	     (rec_lst_3d
	      (vlax-safearray->list
	       (vlax-variant-value
		(vla-get-coordinates x)
	       ) ;_  vlax-variant-value
	      ) ;_  vlax-safearray->list
	     ) ;_  rec_lst_3d
	    ) ;_  rec-rem-dubl
	   ) ;_  apply
   ) ;_  setq
   (vla-put-coordinates
    x
    (vlax-make-variant
     (vlax-safearray-fill
      (vlax-make-safearray
       vlax-vbDouble
       (cons 0 (1- (length l)))
      ) ;_  vlax-make-safearray
      l
     ) ;_  vlax-safearray-fill
    ) ;_  vlax-make-variant
   ) ;_  vla-put-coordinates
  ) ;_  progn
  (princ "\nВы не выбрали трехмерную полилинию")
 ) ;_  if
 (princ)
) ;_  defun

Кулик Алексей aka kpblc · 13.07.2006, 10:56

Можно вопрос? А что означает

Код:

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

(ssget "_+.:E:S"

:?:
Странные вроде какие-то ключи...

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

Женя спасибо! Все работает великолепно!

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

Цитата:

Сообщение от Елпанов Евгений

Набросал по быстрому - безо всяких проверок...

Женя, напмсано действительно "в лоб", и что отдельно приятно - с использованием ActiveX. Но!
1. Что вам помешало выбирать полилинии как объекты сразу, без конветирования примитивов? По-моему, так было бы лучше.
2. Извлекать спмисок вершин удобнее "нелегально" посредчтвом vlax-get. Сэкономили бы кучу печаания.
Короче, что вы скажете о таком варианте (всп. функции опускаю):

Код:

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

(defun c:plopt (/ l x)
  (vla-getEntity (vla-get-utility (vla-get-ActiveDocument (vlax-get-acad-object)))
    'x 'nil "\nSelect 3d Polyline: ")
  (if (= (vla-get-ObjectName x) "AcDb3dPolyline")
    (progn (setq l (apply 'append (rec-rem-dubl (rec_lst_3d (vlax-get x 'coordinates)))));setq
      (vla-put-coordinates x (vlax-make-variant (vlax-safearray-fill
                     (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l))));progn
    (princ "\nВы не выбрали трехмерную полилинию"));if
 (princ) 
) ;defun

По-моему, так удобнее.

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

Лентяй, у вас код растянут вширь, а у Жени по высоте. Так что 1:1

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

Если позволите, усложню задачу.
На верхней картинке показан способ создания линии, для которой представленные программы работают.
Однако, в моей работе достаточно часто встречаются полилинии, построенные так, как показано на нижней картинке.
Если это можно учесть в программе, это было бы замечательно.
Если это сложно, то не мучайтесь - я буду предварительно пользоваться Explode'om и Overkill'om - он иногда выручает в таких ситуациях.
[ATTACH]1152856041.jpg[/ATTACH]

Лентяй · 14.07.2006, 12:18

А по шее наложить этим наложителям наложенных вершин?

Кочетков Андрей · 14.07.2006, 12:52

С радостью, но не получится - это другая программа делает

Кулик Алексей aka kpblc · 14.07.2006, 14:52

> Кочетков Андрей : Попробуй в коде Евгения Елпанова поменять функцию rec-rem-dubl на такое:

Код:

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

(defun rec-rem-dubl (lst / result)
   (foreach x lst
  (if (not (member x result))
   (setq result (cons x result))
  ) ;_ end of if
 ) ;_ end of foreach
 (reverse result)
  ) ;_  defun

Работает?

VVA · 14.07.2006, 14:55

Попробуй этот вариант

Код:

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

(defun c:plopt (/ l x) 
(defun pline-get-verts (pline_obj / verts)
      (setq verts (vlax-get pline_obj 'Coordinates)
      verts
      (cond
        ((wcmatch (vlax-get pline_obj 'Objectname )
           "AcDb2dPolyline,AcDb3dPolyline")
         (group-by-num verts 3))
        ((eq (vlax-get pline_obj 'Objectname )
           "AcDbPolyline")
         (group-by-num verts 2))
        (T nil))))
(defun group-by-num (lst num / ls ret)
  (if (= (rem (length lst) num ) 0)
    (progn
      (setq ls nil)
      (repeat (/ (length lst) num)
  (repeat num (setq ls
        (cons (car lst) ls)
        lst (cdr lst)))
  (setq ret (append ret (list (reverse ls)))
        ls nil))))
ret
  )
(vla-getEntity (vla-get-utility (vla-get-ActiveDocument (vlax-get-acad-object))) 
    'x 'nil "\nSelect any Polyline: ") 
(setq coors (pline-get-verts x))
(foreach pt coors
 (if (not(member pt l))
 (setq l (append l (list pt)))))
(setq l (apply 'append l))
      (vla-put-coordinates x (vlax-make-variant (vlax-safearray-fill 
                     (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l)))
  (princ)
)

В принципе работает со всеми полилиниями, но для LWPOLYLINE иногда выдает

Цитата:

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

но тем не менне LWPOLYLINE рисует

Кочетков Андрей · 14.07.2006, 17:21

>>Крыс
Работает!

>>VVA
Работает, но в конец полилинии добавляется еще одна вершина :roll:

В общем-то на данном этапе задача решена. Спасибо всем, кто откликнулся!

aldt · 14.07.2006, 17:42

"Попробуй в коде Евгения Елпанова поменять функцию rec-rem-dubl на такое:"
для 2-d точек почему-то не работает :cry:

Кулик Алексей aka kpblc · 14.07.2006, 17:50

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

aldt · 14.07.2006, 17:53

((6990.0 6160.0)
(7290.0 6160.0)
(7590.0 6160.0)
(7890.0 6160.0)
(8189.0 6160.0)
(8490.0 6160.0)
(8790.0 6160.0)
(9090.0 6160.0)
(9390.0 6160.0)
(9690.0 6160.0)
(9990.0 6160.0)
(10290.0 6160.0)
(10590.0 6160.0)
(10890.0 6160.0)
(11190.0 6160.0)
(11490.0 6160.0)
(11790.0 6160.0)
(12090.0 6160.0)
(12390.0 6160.0)
(12690.0 6160.0)
((7290.0 6160.0))
((7590.0 6160.0))
((7890.0 6160.0))
((8189.0 6160.0))
((8490.0 6160.0))
((8790.0 6160.0))
((9090.0 6160.0))
((9390.0 6160.0))
((9690.0 6160.0))
((9990.0 6160.0))
((10290.0 6160.0))
((10590.0 6160.0))
((10890.0 6160.0))
((11190.0 6160.0))
((11490.0 6160.0))
((11790.0 6160.0))
((12090.0 6160.0))
((12390.0 6160.0))
((12690.0 6160.0))
((12990.0 6160.0))
)

aldt · 14.07.2006, 17:55

разобрался

Кулик Алексей aka kpblc · 14.07.2006, 17:59

У тебя там элементы странные...

aldt · 14.07.2006, 18:04

Cпасибо за функцию ShaggyDoc и kpblc!!!

VVA · 15.07.2006, 02:13

Вариант программы, работающий со всеми (3d 2d LW) полилиниями.

Код:

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

;Удаление совпадающих вершин из полилинии

(defun c:plopt (/ l x *error* adoc )
  (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 rec-rem-dubl (lst / result) 
   (foreach x lst
     (if (not (member x result))
       (setq result (cons x result))))
  (reverse result) 
  ) ;_  defun
  (defun lwplopt (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 (not(member item pln))
	    (setq pln (append pln cvx))))
      (t (setq pln (append pln (list item))))))
  (entmod pln)(entupd lw))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark adoc)	
  (vla-getEntity (vla-get-utility adoc) 
    'x 'nil "\nSelect any Polyline: ") 
  (cond
    ((member (vla-get-ObjectName x) '("AcDb3dPolyline" "AcDb2dPolyline")) 
     (setq l (apply 'append (rec-rem-dubl (rec_lst_3d (vlax-get x 'coordinates)))));setq 
      (vla-put-coordinates x (vlax-make-variant (vlax-safearray-fill 
                     (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l))))
        ((= (vla-get-ObjectName x) "AcDbPolyline")
	 (lwplopt (vlax-vla-object->ename x)))
    (t (princ "\nВы не выбрали  полилинию")))
  (vla-endundomark adoc)
 (princ) 
) ;defun 
(princ "\nНаберите PLOPT")

Лентяй · 15.07.2006, 05:53

[quote="VVA"]Вариант программы, работающий со всеми (3d 2d LW) полилиниями. [quote]
А вот на фига, спрашивается, вам запонадобилось прыгать от объектов взад на примитивы? [sm2100] Предложили хорошую фукцию, так и используйте ее по полной! Вот так, например:

Код:

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

(defun c:plopt (/ l x *error* adoc ) 
  (defun *error* (message) 
  (princ message)(vla-endundomark adoc)(princ)) 
  (defun rec_lst (lst)
    (if lst (cond ((= (vla-get-ObjectName x) "AcDb3dPolyline")
                   (cons (list (car lst)(cadr lst)(caddr lst)) (rec_lst (cdddr lst))))
                  ((= (vla-get-ObjectName x) "AcDbPolyline")
                   (cons (list (car lst)(cadr lst)) (rec_lst (cddr lst))))));if
  );defun
  (defun rec-rem-dubl (lst / result) 
   (foreach x lst (if (not (member x result)) (setq result (cons x result))))
  (reverse result) 
  );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) 'x 'nil "\nSelect any Polyline: ")))))
    (if (wcmatch (vla-get-ObjectName x) "*Polyline")
      (progn (setq l (apply 'append (rec-rem-dubl (rec_lst (vlax-get x 'coordinates)))));setq
        (vla-put-coordinates x (vlax-make-variant (vlax-safearray-fill
                     (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l))))
      (alert "It's Not a Polyline!!"));if
    (alert "Nothing Selected!!"));if
  (vla-endundomark adoc) 
 (princ) 
);defun 
(princ "\nType PLOPT")

Заметьте, я ничего нового не внес, только перетасовал то. что вы написали ранее.

aldt · 15.07.2006, 07:42

Лентяй.
Функция очень полезная.
посмотрите пожалуйста ,вот тест на котором ваш код не работает.
[ATTACH]1152934955.rar[/ATTACH]

Лентяй · 15.07.2006, 09:00

aldt, в чем ваша проблема? У вас же нету совпадающих вершин! Вы, случайно, тему не перепутали?
Вот кстати, ваш файл, обработанный моей модификацией VVA-вской программы по удалению лишних вершин.
[ATTACH]1152940210.dwg[/ATTACH]

aldt · 15.07.2006, 10:10

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

VVA · 15.07.2006, 16:40

>Лентяй
Так при работе с LW в ActiveX у меня через раз выскакивало

Цитата:

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

И, как сказал Крыс, в ActiveX я не Копенгаген, поэтому пришлось спуститься с небес на землю. Посмотрю по вашему коду что не так делал.

Лентяй · 17.07.2006, 08:14

У меня это тоже ингда выскакивает при работе с LW-полилиниями. Почему- понятия не имею. Операция замещения координат ранее всегда происходила без проблем. Правда. никогда их число не уменьшалось с неск. десятков до 2. Полагаю, что дело в слишком кардинальных изменениях, вызывающих некие проблемы на уровне, близком к железному. В тоже время, с 3-D полилиниями проблем нет. Так что - будем думать! [sm2003]

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

Думание закончено! На http://dwg.ru/forum/viewtopic.php?t=...r=asc&start=15 выложены варианты работающих программ. [sm166]

VVA · 18.07.2006, 17:55

Вариант работающей со всеми полилиниями программы по найденному решению Лентяя

Код:

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

;;;Удаление совпадающих вершин из полилинии
(defun c:plopt (/ l ls lst vx pl *error* adoc result cv)
  (defun *error* (message) 
  (princ message)(vla-endundomark adoc)(princ)) 
  (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))) 
  (vla-startundomark adoc) 
  (if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () 
             (vla-getEntity (vla-get-utility adoc) 'pl 'nil "\nSelect any Polyline: "))))) 
    (if (wcmatch (vla-get-ObjectName pl) "*Polyline") 
      (progn
	(setq vx (rec_lst (vlax-get pl 'coordinates)) cv 0 ls vx)
	(foreach item vx
	  (setq ls (cdr ls))
          (if (member item result)
	    (progn
	      (setq lst (append result ls))
	      (setq l (apply 'append lst))
	      (vla-put-coordinates pl (vlax-make-variant (vlax-safearray-fill 
                     (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length l)))) l)))
	      (setq cv (1+ cv))
	      )
	    (setq result (append result (list item)))
	    )
	  )
	(princ "\nRemoved ")(princ cv)(princ " vertex from polyline")
        ) 
      (alert "It's Not a Polyline!!"));if 
    (alert "Nothing Selected!!"));if 
  (vla-endundomark adoc) 
 (princ) 
);defun 
(princ "\nType PLOPT")

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

Еще раз спасибо!

13.07.2006, 10:22		#1
Удаление совпадающих вершин из полилинии Кочетков Андрей Java/Kotlin/Go Регистрация: 03.02.2006 Сообщений: 5,789 Господа программисты, мне нужна программа, которая удаляет из трехмерной полилинии вершины с одинаковыми координатами. Спасибо за потраченное на меня время
Просмотров: 11219