Тема: LISP. Группировка и разгруппировка объектов
Тема началась на https://www.caduser.ru/forum/topic22179.html И результатом стало с минимальными переделками (тогда думать было лень, сейчас вроде как исправился):
;|============================================================================= * Функция группировки и разгруппировки. * Параметры вызова: * grouping nil -> разгруппировать. t -> группировать * Примеры вызова: (kpblc-univ-grouping t) ;группировать выбранные объекты в безымянную группу (kpblc-univ-grouping nil) ;разгруппировать объекты. Удалить запись о группе =============================================================================|; (defun kpblc-univ-grouping (grouping / selset error_catch item counter group sub_item ) ;; Локальные функции (defun error_catch (msg) (vla-endundomark *kpblc-activedoc*) (princ msg) ) ;_ end of defun ;; Конец локальных функций (vl-load-com) (if (not *kpblc-activedoc*) (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object))) ) ;_ end of if (vla-startundomark *kpblc-activedoc*) (setq *error* error_catch counter 0 ) ;_ end of setq (princ "\nУкажите объекты") (if (not (setq selset (ssget "_I"))) (setq selset (ssget)) ) ;_ end of if (while (and selset (setq item (ssname selset counter))) (setq counter (1+ counter)) (if (and (assoc 330 (entget item)) (setq group (cdr (assoc 330 (entget item)))) (eq (cdr (assoc 0 (entget group))) "GROUP") ) ;_ end of and (progn ;; Засовываем в selset объекты, принадлежащие группе (setq group (vlax-ename->vla-object group)) (vlax-for sub_item (vla-item (vla-get-groups *kpblc-activedoc*) (vla-get-name group) ) ;_ end of vla-item (ssadd (vlax-vla-object->ename sub_item) selset) ) ;_ end of vlax-for (entdel (vlax-vla-object->ename group)) ;Удаление записи о группе ) ;_ end of progn ) ;_ end of if ) ;_ end of while ;; Теперь собственно [раз]группировка выбранных объектов. (if grouping (if (vl-cmdf "_.-group" "_create" "*" "" selset "") (princ "\nОбъекты успешно добавлены в группу") (princ "\nОшибка добавления объектов") ) ;_ end of if ) ;_ end of if (sssetfirst nil nil) (vla-endundomark *kpblc-activedoc*) (princ) ) ;_ end of defun ;|============================================================================= * Сервисная функция. Служит для вызова основной функции с командной строки. * Выполняет группировку объектов. Лично у меня именно этот вариант бОльшей * популярностью пользуется. * Параметры вызова: * нет и быть не может * Примеры вызова: (c:grp) ; из lisp-функций grp ; с командной строки =============================================================================|; (defun c:grp () (kpblc-univ-grouping t) ) ;_ end of defun ;|============================================================================= * Сервисная функция. Служит для вызова основной функции с командной строки. * Выполняет группировку объектов. Лично у меня именно этот вариант бОльшей * популярностью пользуется. * Параметры вызова: * нет и быть не может * Примеры вызова: (c:ung) ; из lisp-функций ung ; с командной строки =============================================================================|; (defun c:ung () (kpblc-univ-grouping nil) ) ;_ end of defun ;|============================================================================= * Сервисная функция. Служит для вызова основной функции с командной строки. * Выполняет группировку объектов с запросом из ком.строки. * Параметры вызова: * нет и быть не может * Примеры вызова: (c:ugq) ; из lisp-функций unq ; с командной строки =============================================================================|; (defun c:ugq (/ _answer_) (initget "Группировать Разгруппировать Group Ungroup _ G U G U") (setq _answer_ (getkword "\nВыполнять действия [Группировать/Разгруппировать] <Отмена> : " ) ;_ end of getkword ) ;_ end of setq (if _answer_ (kpblc-univ-grouping (= _answer_ "G")) ) ;_ end of if ) ;_ end of defun