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

Кочетков Андрей · 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")

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