[Кочетков Андрей]

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

[Лентяй]

[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]

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

[Лентяй]

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

[aldt]

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

[VVA]

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

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

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

[Лентяй]

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

[Лентяй]

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

[VVA]

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

Код:

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

;;;Удаление совпадающих вершин из полилинии
(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")

[Кочетков Андрей]

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