dwg.ru forum rss xml
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Готовые программы > LISP. Удаление совпадающих вершин в полилинии (вариант). Пример использования.

LISP. Удаление совпадающих вершин в полилинии (вариант). Пример использования.

Версия для печати
 
Ответ
Опции темы Поиск в этой теме
Непрочитано 16.09.2018, 11:47 #1
LISP. Удаление совпадающих вершин в полилинии (вариант). Пример использования.
Profan
 
Москва
Регистрация: 25.12.2005
Сообщений: 13,674

Profan вне форума Вставить имя

Простейшая программа для удаления совпадающих вершин в полилинии.
Код:
[Выделить все]
;;; Удаление совпадающих вершин в полилинии с помощью команды "_-OVERKILL" ("-ПОДЧИСТИТЬ")
(defun C:D-Vx-PL ( / pll)
(setq pll (car (entsel "\nУкажите контур: ")))
(if (and pll (= (cdr (assoc 0 (entget pll))) "LWPOLYLINE"))
    (vl-cmdf "_-OVERKILL" pll "" "_P" "_B" "_N" "_Y" "")
) ; if
(princ)
)

Последний раз редактировалось Profan, 16.09.2018 в 16:22.
Просмотров: 1006
 
Непрочитано 16.09.2018, 12:10
#2
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,019


По-моему, в "Новых командах по работе с полилиниями" нечто подобное уже было.

----- добавлено через ~7 мин. -----
Второй вариант, без использования командных методов:
Код:
[Выделить все]
 (vl-load-com)

(defun tt (/ ent coord lst)
  (if (= (type
           (setq ent (vl-catch-all-apply (function (lambda () (ssname (ssget "_+.:L:E:S" '((0 . "LWPOLYLINE"))) 0)))))
           ) ;_ end of type
         'ename
         ) ;_ end of =
    (progn (setq coord (mapcar (function cdr) (vl-remove-if-not (function (lambda (x) (= (car x) 10))) (entget ent)))
                 ent   (vlax-ename->vla-object ent)
                 ) ;_ end of setq
           (foreach item coord
             (if (not (equal (car lst) item 1e-3))
               (setq lst (cons item lst))
               ) ;_ end of if
             ) ;_ end of foreach
           (setq lst (apply 'append (reverse lst)))
           (vla-put-coordinates ent
                                (vlax-make-variant
                                  (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length lst)))) lst)
                                  ) ;_ end of vlax-make-variant
                                ) ;_ end of vla-put-Coordinates
           (princ)
           ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 16.09.2018, 16:21
#3
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,674


Используя мой код, а также предложение Евгения Елпанова отсюда
http://www.caduser.ru/forum/index.ph...D=44&TID=36569
можно написать простенькую программу выбора всех объектов внутри указанного контура-полилинии:
Код:
[Выделить все]
;;; Выбор объектов внутри контура-полилинии.
(defun C:SEL-PL ( / echo pll fuzz ss)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq pll (car (entsel "\nУкажите контур-полилинию: ")))
(if (and pll (= (cdr (assoc 0 (entget pll))) "LWPOLYLINE"))
    (progn
    (vl-cmdf "_-OVERKILL" pll "" "_P" "_B" "_N" "_Y" "")
    (setq fuzz 0.5) ; точность проверки..
    (vl-cmdf "_ZOOM" "_O" pll "")
    (setq ss (ssget "_WP" (ACET-GEOM-OBJECT-POINT-LIST pll fuzz)))
    (sssetfirst ss ss)
    (princ (strcat "\nВыбрано " (itoa (sslength ss)) " объектов."))
    ) ; progn
    (princ "\nКонтур-полилиния не выбран.")
) ; if
(setvar "CMDECHO" echo)
(princ)
)
Необходим установленный пакет программ Express Tools.
Profan вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Непрочитано 16.09.2018, 23:33
#4
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,130


Вот нарыл в дальних закромах. Почти, как у kpblc'а, только не с фиксированным линейным, а с переменным угловым допуском.

Код:
[Выделить все]
 (defun C:PlVxRdc ( / pl adoc *error* vx lst pang tol 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)
        util (vla-get-utility 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")
Лентяй вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 17.09.2018, 06:41
#5
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,674


Ребята, вот для чего вы упражняетесь в нагромождении функций? Я ведь предложил максимально простое решение с использованием штатных возможностей AutoCAD'а. Ведь раньше, когда OVERKILL входила в состав ET, в ней не было еще тех возможностей, которые появились, когда эта функция стала штатной командой AutoCAD'а. А всякие другие решения неоднократно обсуждались на просторах caduser.ru (autocad.ru) и dwg.ru.
Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
По-моему, в "Новых командах по работе с полилиниями" нечто подобное уже было.
Мне ли не знать, поскольку я стоял у истоков создания пакета программ Pltools...
Profan вне форума вставить имя Обратить внимание модератора на это сообщение  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Готовые программы > LISP. Удаление совпадающих вершин в полилинии (вариант). Пример использования.

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Выделение множества вершин полилинии Марьев Павел AutoCAD 17 25.04.2018 16:48
LISP. Как в ActiveX выдернуть координаты полилинии? Как задавать атребуты блока через LISP? wpww LISP 31 16.08.2016 14:17
Как удалить тип линии Tolyanovich AutoCAD 48 20.11.2014 09:24
LISP. Как преобразовать выделенные сплайны в полилинии? LastGraff LISP 11 19.12.2013 11:07
Как увеличить точность отображения координат вершин полилинии ? swkx Программирование 8 25.04.2013 15:27

|| Главная || Каталог САПР || Тендеры || Публикации || Объявления || Биржа труда || Download || Галерея ||
|| Библиотека || Кунсткамера || Каталог предприятий || Контакты || Файлообменник || Блоги ||