Lisp或代码分解组
大家好。是否有任何现成的lisp或代码可以分解一组
请由集团指挥部收集？
谢谢大家。
甜甜的 这是一个很好的“清除”例程集合（PurgeAllGroups）
克鲁格
亲爱的克鲁格，收藏在哪里？
XXXXXXX以上 UPSS:oops:link在这里：http://www.jtbworld.com/lisp/purger.htm
克鲁格 试试看
PAG-清除所有组
PEG-清除空组
PUG-清除未命名的组（如*Annn）
; Ф-ция PurgeAllGroups
; Удаляет описание всех групп
; Аргумент [Тип]:
; НЕТ
; Возвращает: Nil
(vl-load-com)
(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 = Тип
; 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 = Имя группы
; Возвращает: 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 :
; Obj = Object
; Obj = Object
; Возвращает :
; Список имен групп
;
(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))
谢谢。
但我并不期待使用purge命令，尽管Autocad中已经存在该命令。
我需要在通过group命令相互收集的实体上分解group。
谢谢 图形中的所有“组”还是特定组？按名称还是通过选择？ 你试过我的或VVA代码吗？
此处的清除意味着分解所有组（不能使用autocad Purge命令清除组）。
克鲁格
非常感谢VVA先生。
那真的很棒。
但是如何通过用户选择一个又一个呢？
感谢
是的，如果我能一组一组地选出来就太好了。
谢谢
页:
[1]
2