Topic: deleting unused groups

[Bob Wahr]

Total development time on this was around 15 minutes.  There is no error trapping, no warranty, and not much thought involved.  I don't see how it can do anything worse to your drawings than deleting groups that you didn't want to delete, but if it does, I take no blame.  Conversly, if it works, I take all the credit.


Mark, if you see this, how about adding dvb as an attachable extension?

[ELOQUINTET]

pretty cool bob but i wouldn't want it to list groups that are in use. how would you filter those out?

[MP]

(if (zerop (vla-get-count group)) ... )

[LE]

Here are some functions that might be useful [the code is very old, and I got some participation from Cliff Middleton]

HTH

Code: [Select]

;;; convert a list of vla-objects into
;;; a variant array of objects
;;; usage:
;;; (lbx-array-of-objects [vla objects list])
(defun lbx-array-of-objects (vla-lst)
       (vlax-safearray-fill
(vlax-make-safearray
   vlax-vbobject
   (cons 0 (1- (length vla-lst)))
)
vla-lst
       )
)

;;; get all the existing groups names
;;; and as a vla-object inside a list
;;; usage:
;;; (lbx-get-groups [active-document])
;;; return:
;;; list with name and vla-object
;;; (("TEST1" . #<VLA-OBJECT IAcadGroup 01acd204>)
;;;  ("TEST2" . #<VLA-OBJECT IAcadGroup 01acd164>))
;;; test:
;;; (setq lst (lbx-get-groups (lbx-get-active-document)))
(defun lbx-get-groups (doc / grp-data)
       (setq grp-data nil)
       (vlax-for group (vla-get-groups doc)
(setq
   grp-data (append grp-data
    (list (cons (vla-get-name group) group))
    )
)
       )
)

;;; get the vla-object of a group name
;;; usage:
;;; since the name of groups cannot be lowercase
;;; or a string in the form "TEST 1"
;;; we need the appropiate name, the function
;;; takes care of turning the name to uppercase
;;; (lbx-get-group [group name as string])
;;; return:
;;; vla-object or nil
;;; #<VLA-OBJECT IAcadGroup 01acd204>
;;; test:
;;; (setq vla-group (lbx-get-group "test1"))
;;; (vla-highlight vla-group :vlax-false)
(defun lbx-get-group (name)
  (cdr
    (assoc (strcase name)
   (lbx-get-groups (lbx-get-active-document))
    )
  )
)

;;; get the vla-objects belonging to a group
;;; usage:
;;; (lbx-get-group-objects [vla-object])
;;; return:
;;; list of vla-objects or nil
;;; test:
;;; (lbx-get-group-objects (lbx-get-group "TEST1"))
;;; (#<VLA-OBJECT IAcadLine 01ace434>
;;;  #<VLA-OBJECT IAcadLine 01ace4d4>
;;; )
(defun lbx-get-group-objects (vla-group / items)
       (setq items nil)
       (vlax-for _obj vla-group (setq items (cons _obj items)))
)

;;; pass a selection to a group
;;; usage:
;;; (lbx-appenditems [selection set] [vla-object])
;;; previous number of items and the new count
;;; test:
;;; (lbx-appenditems ss vla-group)
(defun lbx-appenditems (ss vla-group / current-items tmp)
       (setq current-items (vla-get-count vla-group))
       (setq tmp nil)
;;; make sure new objects are not already in the group
;;; create a new list with valid elements
       (foreach e (lbx-ssget->vla-list ss)
(if (not (member e (lbx-get-group-objects vla-group)))
   (setq tmp (cons e tmp))
)
       )
       (if (and tmp (listp tmp) (/= nil (vl-remove nil tmp)))
(progn
   (vla-appenditems vla-group (lbx-array-of-objects tmp))
   (if *eng*
     (strcat "\nPrevious items <"
     (itoa current-items)
     ">, new count: "
     (itoa (vla-get-count vla-group))
     )
     (strcat "\nElementos anterioremente <"
     (itoa current-items)
     ">, cuenta nueva: "
     (itoa (vla-get-count vla-group))
     )
   )
)
       )
)

;;; removes specified items from the group
;;; usage:
;;; maybe will be a good idea to use the group name
;;; included with the vla-object
;;; (lbx-removeitems [vla list] [vla-object group])
;;; test:
;;; (lbx-removeitems lst vla-group)
(defun lbx-removeitems (items vla-group / current-items tmp)
       (setq current-items (vla-get-count vla-group))
       (setq tmp nil)
;;; make sure objects on the list are in the group
;;; before remove them and create a new list with
;;; the valid elements
       (foreach e items
(if (member e (lbx-get-group-objects vla-group))
   (setq tmp (cons e tmp))
)
       )
       (if (and tmp (listp tmp) (/= nil (vl-remove nil tmp)))
(progn
   (vla-removeitems vla-group (lbx-array-of-objects tmp))
   (if *eng*
     (strcat "\nPrevious items <"
     (itoa current-items)
     ">, new count: "
     (itoa (vla-get-count vla-group))
     )
     (strcat "\nElementos anteriormente <"
     (itoa current-items)
     ">, cuenta nueva: "
     (itoa (vla-get-count vla-group))
     )
   )
)
       )
)

;;; get a entity selection
;;; (lbx-ent-selection "Select object to remove")
;;; convert to vla-object's
;;; (setq lst (lbx-ents-to-vlas lst))
(defun lbx-ent-selection (msg / ent ents)
  (setq ents nil)
  (while (setq ent (car (entsel (strcat "\n" msg ": "))))
    (if (and ent (= 'ENAME (type ent)))
      (progn
(redraw ent 3)
(setq ents (cons ent ents))
      )
    )
  )
)

;;; get group names available
(defun lbx-get-group-names (/)
  (mapcar 'car (lbx-get-groups (lbx-get-active-document)))
)

;;; (lbx-make-group "TEST")
;;; return:
;;; vla-object or nil
(defun lbx-make-group (name)
       (if (not (vl-position name (lbx-get-group-names)))
(vla-add (vla-get-groups (lbx-get-active-document)) name)
       )
)

;;; usage:
;;; (lbx-part-of-group [vla-obj])
;;; return group name
;;; "TEST"
(defun lbx-part-of-group (obj)
  (car
    (vl-remove
      nil
      (mapcar
'(lambda (l)
   (if (member obj l)
     (car l)
     nil
   )
)
(mapcar
  '(lambda (g) (cons (car g) (lbx-get-group-objects (cdr g))))
  (lbx-get-groups (lbx-get-active-document))
)
      )
    )
  )
)

;;; lbx-PUT-OBJECTS
;;; Creates new group or appends
;;; objects to an existing group
;;; Arguments
;;; 1) group name <string>
;;; 2) list of entities as vla-objects
;;; 3) document object
(defun lbx-put-objects (groupname vla-objects doc)
  (lbx-append-objects
    (lbx-get-or-create groupname doc)
    vla-objects
  )
)

;;; lbx-GET-OR-CREATE
;;; Creates a group object,
;;; or returns existing group
;;; Arguments
;;; 1) group name <string>
;;; 2) document object
;;; Note vla-add in a2k will not accept "*"
;;; as a group name, hence the copy made
(defun lbx-get-or-create (groupname doc / tempgrpobj sArray grpobj)
       (if (wcmatch groupname "*`**")
(progn
   (setq
     tempgrpobj (vla-add (vla-get-groups doc)
"upgradenecessitator"
)
     sArray
(vlax-safearray-fill
  (vlax-make-safearray
    vlax-vbobject
    (cons 0 0)
  )
  (list tempgrpobj)
)
     grpobj
(car
  (vlax-safearray->list
    (vlax-variant-value
      (vla-copyobjects doc sarray)
    )
  )
)
   )
   (vla-delete tempgrpobj)
)
(if (not (member (strcase groupname) (lbx-list-groups doc)))
   (setq grpobj (vla-add (vla-get-groups doc) groupname))
   (setq grpobj (vla-item (vla-get-groups doc) groupname))
)
       )
  grpobj
)

;;; lbx-APPEND-OBJECTS
;;; Append objects to group
;;; Arguments
;;; 1) group object <vla-object>
;;; 2) list of entities as vla-objects
(defun lbx-append-objects (grpobj vla-objects)
       (vla-appenditems
grpobj
(vlax-safearray-fill
   (vlax-make-safearray
     vlax-vbobject
     (cons 0 (1- (length vla-objects)))
   )
   vla-objects
)
       )
  grpobj
)

;;; lbx-LIST-GROUPS
;;; Argument
;;; 1) Document object
;;; Returns upper-case list of groups
(defun lbx-list-groups (doc / return)
       (vlax-for group (vla-get-groups doc)
(setq return (cons (vla-get-name group) return))
       )
       (mapcar 'strcase (reverse return))
)

;;; lbx-NEXT-NAME
;;; Argument
;;; 1) Group name
;;; 2) Document object
;;; Returns unique group name by appending
;;; an integer <as string> to the groupname
(defun lbx-next-name (groupname doc / groupnames pattern family)
  (if (member (setq groupname (strcase groupname))
      (setq groupnames (lbx-list-groups doc))
      )
    (progn
      (setq pattern (strcat groupname "*"))
      (mapcar '(lambda (g)
(if (wcmatch g pattern)
   (setq family (cons g family))
)
       )
      groupnames
      )
      (strcat
groupname
(itoa
  (1+
    (eval
      (cons
'max
(mapcar '(lambda (g) (atoi (vl-string-trim groupname g)))
family
)
      )
    )
  )
)
      )
    )
    groupname
  )
)

;;; revisar porque se tienen que seleccionar
;;; mas de dos objetos para que los pase a el grupo?
(defun add-objects-to-group ()
  (if (setq ent (car (entsel (if *eng*
       "\nSelect entity on group: "
       "\nSeleccionar entidad en grupo: "
     )
     )
)
      )
    (progn
      (redraw ent 3)
      (setq obj (vlax-ename->vla-object ent))
      (if (setq ss (lbx-ssget-prompt
     (if *eng*
       "Add objects to the group"
       "Adherir elementos a el grupo"
     )
     nil
   )
  )
(lbx-appenditems ss (lbx-get-group (lbx-part-of-group obj)))
      )
      (redraw ent 4)
    )
  )
)

(princ)