Тема: 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

Re: LISP. Группировка и разгруппировка объектов

Спасибо еще раз.

Re: LISP. Группировка и разгруппировка объектов

Ну Вы в курсе :)

Re: LISP. Группировка и разгруппировка объектов

А нафига "Отмена" в контекстном меню?

Re: LISP. Группировка и разгруппировка объектов

Мне кажется вместо <Отмена> должно быть <Группировать> или <Разгруппировать>, как кому удобно.

Re: LISP. Группировка и разгруппировка объектов

> Nino
Один человек попросил на всякий случай дать возможность выхода именно таким методом. А для всех сделать удобный вариант у меня не хватает фантазии. Если хочется, можно переделать последнюю функцию по следующему алгоритму:

;;; Для варианта [b]Группировать[/b] по умолчанию
(defun c:ugq (/ _answer_)
  (initget "Группировать Разгруппировать Group Ungroup _ G U G U")
  (setq _answer_
         (getkword
           "\nВыполнять действия [Группировать/Разгруппировать] <Группировать> : "
           ) ;_ end of getkword
        ) ;_ end of setq
  (if (not _answer_) (setq _answer_ "G"))
  (if _answer_
    (kpblc-univ-grouping (= _answer_ "G"))
    ) ;_ end of if
  ) ;_ end of defun

Для разгруппировки по умолчанию переделать строку (getkword) и заменить

(if (not _answer_) (setq _answer_ "G"))

на

(if (not _answer_) (setq _answer_ "U"))

Хотя в таком варианте ИМХО будет проще пользоваться 2 разными функциями...

Re: LISP. Группировка и разгруппировка объектов

IMHO, опция "Отменить" не лишняя, вдруг я передумал группировать или разгруппировать. Только ее как раз и нет в контекстном меню, надо бы дописать.

Re: LISP. Группировка и разгруппировка объектов

> Владимир Громов
Полный код приводить? Или только последнюю функцию? Я-то как-то постоянно сталкиваюсь с тем, что для отмены либо жмут Esc, либо в конт.меню выбирают вторую сверху строчку. Так что Отмена есть и неявно.
Ладно, я надеюсь, что изменить код труда не составит.

Re: LISP. Группировка и разгруппировка объектов

> kpblc
Да, код изменить не трудно. Я бы написал <Enter-отмена>. Да можно и так оставить, нажимать Enter или Пробел. Только возвращается nil, тоже ерунда, не страшно.

Re: LISP. Группировка и разгруппировка объектов

> kpblc
Я так у себя и сделал. Для меня Esc  удобнее, чем лишняя навигация по контекстному меню. Мне кажется ошибаемся с командой мы не часто, а пользуем данное меню чаще и ОТМЕНА мозолит глаза, да и заставляет делать лишние телодвижения.
В любом случае каждый сам может выбрать удобный для себя вариант, благо поправить код секундное дело.

Re: LISP. Группировка и разгруппировка объектов

Еще пару ф-ций по работе с группами

; Ф-ция PurgeAllGroups
; Удаляет описание всех групп
; Аргумент [Тип]:
;   НЕТ
; Возвращает: Nil
  (defun PurgeAllGroups (/ grpList index grp)
  (setq grpList (dictsearch (namedobjdict) "ACAD_GROUP"))
  (setq index 1)
  (while (setq grp (nth index grplist))
    (if    (= (car grp) 3)
      (entdel (cdr (nth (+ index 1) grplist)))
    )
    (setq index (+ 1 index))
  )
  (princ))
; Ф-ция PurgeEmptyGroups
; Удаляет описание всех пустых групп
; Аргумент [Тип]:
;   Named = Тип [INT]
;       0 - только именованные группы
;       1 - только неименованные группы
;   t,nil - все группы
; Возвращает: Nil
(defun PurgeEmptyGroups ( named / grpList index grp egrp named_list e_list)
  ;;; Библиотечная ф-ция, возвращает multiple group code
(defun massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
    ))
  (reverse nlist))
  (setq named_list '(0 1))
  (if (member named named_list)(setq named_list (list named)))
  (setq grpList (dictsearch (namedobjdict) "ACAD_GROUP"))
  (setq index 1)
  (while (setq grp (nth index grplist))
    (if    (= (car grp) 3)
      (progn
    (setq egrp (entget (cdr (nth (+ index 1) grplist))))
    (if (member (cdr (assoc 70 egrp)) named_list)
      (progn
        (setq e_list (massoc 340 egrp))
        (if(not (vl-member-if 'entget e_list))
          (entdel (cdr (nth (+ index 1) grplist)))
          )
        )
      )
    )
      )
    (setq index (+ 1 index))
  )
  (princ))
; Ф-ция PurgeAllUnNamedGroups
; Удаляет описание всех анонимных групп *Annn
; Аргумент [Тип]:
; НЕТ
; Возвращает: Nil
(defun PurgeAllUnNamedGroups (/ grpList index grp)
  (setq grpList (dictsearch (namedobjdict) "ACAD_GROUP"))
  (setq index 1)
  (while (setq grp (nth index grplist))
    (if    (= (car grp) 3)
      (progn
    (if (= (chr 42) (substr (cdr grp) 1 1))
      (entdel (cdr (nth (+ index 1) grplist)))
    )
      )
    )
    (setq index (+ 1 index))
  )
  (princ)
)
; Ф-ция DeleteGroupbyName
; Удаление группы по имени.
; Аргумент [Тип]:
;   Name = Имя группы [STR]
; Возвращает: Null
(defun DeleteGroupbyName (Name)
(or *kpblc-activedoc*
   (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
)
 (vl-catch-all-apply
 '(lambda ()
   (vla-delete
    (vla-item
     (vla-get-groups *kpblc-activedoc*)
     Name
    )
   )
  )
 )
 (princ)
)
; Ф-ция GetObjGroupNames
; Возвращает список имен групп объекта или nil.
; Arguments [Type]:
;   Obj = Object [VLA-OBJECT]
;   Obj = Object [ENAME]
; Возвращает [Type]:
;   Список имен групп [list]
;
(defun GetObjGroupNames (Obj / Cur_ID NmeLst)
 (or *kpblc-activedoc*
   (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
)
 (if (= (type Obj) 'ENAME)(setq Obj (vlax-ename->vla-object Obj)))
 (setq Cur_ID (vla-get-ObjectID Obj))
 (vlax-for Grp (vla-get-Groups *kpblc-activedoc*)
  (vlax-for Ent Grp
   (if (equal (vla-get-ObjectID Ent) Cur_ID)
    (setq NmeLst (cons (vla-get-Name Grp) NmeLst))
   )
   (vlax-release-object Ent)
  )
  (vlax-release-object Grp)
 )
 (reverse NmeLst)
)
 ;;;Удаляет все пустые группы (именованные и неименованные)
 ;;;Объеткты, входящие в группы удаленны, а описание групп осталось
 ;;;http://dwg.ru/forum/viewtopic.php?t=4762
(defun PurgeAllEmptyGroups  ()(PurgeEmptyGroups t))
 ;;;Удаляет все пустые группы (именованные)
(defun PurgeAllNamedEmptyGroups  ()(PurgeEmptyGroups 0))
 ;;;Удаляет все пустые группы (неименованные)
(defun PurgeAllUnNamedEmptyGroups  ()(PurgeEmptyGroups 1))
;;;=======================================================
;;; Команды
;;;=======================================================
;;; Удаляет все группы Purge All Groups
(defun C:PAG ()(PurgeAllGroups))
;;; Удаляет все пустые группы   Purge Empty Groups
(defun C:PEG ()(PurgeAllEmptyGroups))
;;; Удаляет все неименованные группы  Purge Unnamed Groups
(defun C:PUG ()(PurgeAllUnNamedGroups))
Спасибо сказали: doctorRAZ1

(изменено: Владимир Азарко, 9 августа 2013г. 13:56:21)

Re: LISP. Группировка и разгруппировка объектов

Еще пару команд для работы с группами есть здесь
Как расформировать группы?