;;;-------------------purgegroups.lsp-----------------------------
;;;  Purpose: Purge groups which contain zero or at most one entity
;;;  Purpose: List useful information on groups in a drawing file
;;;  Usage: AutoCAD 2000 & up
;;;  Version: 1.1
;;;  Date this file: 3 May 2003
;;;  © 2003 Herman Mayfarth
;;;  No warranty, express or implied. Use at your own risk.
;;;  
;;;  Acknowledgements: This topic has been discussed numerous times on
;;;  autodesk.autocad.customization. Thanks to all participants, and
;;;  especially to a) Tony Tanzillo, who pointed out that one-entity groups
;;;  seem essentially pointless, and b) Marc'Antonio Alessi, who discovered
;;;  changes in how group dictionary entries are handled in R14 AutoLISP vs.
;;;  R2000-> (non-Active X approach) & inspired me to try Active X methods.
;;;  Doug Broad, Ken Alexander, & John Uhden also posted very similar code.
;;;---------------------------------------------------------------
;;; the following was the first "Active X" function i wrote to do this
;;; it is presented only for comparison with function which follows
;;;-----------------purgegroups1----------------------------------
;;;function to delete groups containing zero or one entities 
;;;pass a non-nil argument to delete one-entity groups
;;;pass any nil value to delete only null groups
(defun purgegroups1 (one / count i num groups)
  (vl-load-com)
  ;;get groups collection of current document
  (setq groups (vla-get-groups (vla-get-activedocument (vlax-get-acad-object)))
        count (vla-get-count groups);# of groups in dwg
        i 0 ;loop counter
  )
  (if one
    (setq num 1);purge one entity & null groups
    (setq num 0);purge only null groups
  )
  (while (< i (vla-get-count groups));vla-get-count is updated on delete!
    (if (<= (vla-get-count (vla-item groups i)) num)
      (vla-delete (vla-item groups i))
      (setq i (1+ i));so increment only if no deletion occurs 
    )
  )
  (- count (vla-get-count groups));return # groups deleted
);purgegroups1
;;;the above function can be made more efficient, since
;;;we can do this a "purer" active x way, using (vlax-for)
;;;--------------------purgegroups----------------------------
;;;function to delete groups containing zero or one entities
;;;pass a non-nil argument to delete one-entity groups
;;;pass any nil value to delete only null groups
(defun purgegroups (one / count num groups)
  (vl-load-com)
  ;;get groups collection of current document
  (setq groups (vla-get-groups (vla-get-activedocument (vlax-get-acad-object)))
        count (vla-get-count groups);# of groups in dwg
  )
  (if one
    (setq num 1);purge one entity & null groups
    (setq num 0);purge only null groups
  )
  (vlax-for group groups
    (if (<= (vla-get-count group) num)
      (vla-delete group)
    )
  )
  (- count (vla-get-count groups));return # groups deleted
);purgegroups
;;;----------------------listgroups------------------------
;;;  Purpose: List information on GROUPs in drawing database
;;;  Usage: AutoCAD 2000 & up
;;;  © 2003 Herman Mayfarth
;;;  no warranty, express or implied. use at your own risk.
;;;  Date this file: 23 April 2003
;;;--------------------------------------------------------
;;helper function
(defun padright-or-trunc (str char len )
  (if (> (strlen str) len )
    (substr str 1 len)
    (repeat (- len (strlen str))
      (setq str (strcat str char))
    )
  );if
)
;;function to list all groups in a dwg & # entities in each
(defun listgroups ( verbose / 
                      1item-count
                      anon-count
                      count
                      groups
                      i
                      item
                      name
                      nonselect-count
                      null-count
                      num
                      select
                   )
  (vl-load-com)
  ;;get groups collection of current document
  (setq groups (vla-get-groups (vla-get-activedocument (vlax-get-acad-object)))
        count (vla-get-count groups);# of groups in dwg
        i 0 ;loop counter
        null-count 0;# empty groups
        1item-count 0;# 1 entity groups
        anon-count 0;# anonymous groups
        nonselect-count 0;# non-selectable groups
  )
  (if verbose
    (progn
      (princ "\nIndex   Name                #Entities   Selectable")
      (princ "\n--------------------------------------------------")
    )
  )
  (repeat count
    (setq item (vla-item groups i)
          name (vla-get-name item)
          num  (vla-get-count item)
    )
    (cond ((= num 0) (setq null-count (1+ null-count)))
          ((= num 1) (setq 1item-count (1+ 1item-count)))
    )
    (if (= "*A" (substr name 1 2))
      (setq anon-count (1+ anon-count)) 
    )
    ;;active X interface does not include a property for group selectability
    ;;so convert the vla-object -> ename and (entget ename)
    ;;then check group code 71 (1 = selectable)
    (if (= 0 (cdr (assoc 71 (entget (vlax-vla-object->ename item)))))
      (setq nonselect-count (1+ nonselect-count)
            select "No"
      )
      (setq select "Yes")
    )
    (if verbose
      (princ (strcat "\n" (padright-or-trunc (itoa i) " " 8)
                          (padright-or-trunc name " " 18)
                         "  "
                         (padright-or-trunc (itoa num) " " 10)
                         "  "
                         select
            )
      )
    )

    (setq i (1+ i))
  )
  (if verbose
    (progn
      (princ "\n--------------------------------------------------")
      (princ "\nIndex   Name                #Entities   Selectable")
      (princ "\n--------------------------------------------------")
    )
  )
  (princ (strcat "\nTotal # Groups = " (itoa i)))
  (princ (strcat "\nEmpty Groups = " (itoa null-count)))
  (princ (strcat "\nOne Entity Groups = " (itoa 1item-count)))
  (princ (strcat "\nAnonymous Groups = " (itoa anon-count)))
  (princ (strcat "\nNon-selectable Groups = " (itoa nonselect-count)))
  (textscr)
  (princ)
);listgroups
;;command to list groups
(defun C:Listgroups ( / )
  (initget "Yes No")
  (if (= (getkword "\nVerbose Mode (List Groups)? Yes/No <No>") "Yes" )
    (listgroups T)
    (progn (princ "\nWorking..\n")(listgroups nil))
  )
  (princ)
);C:Listgroups
;;command to purge groups
(defun C:Purgegroups ( / single base timer size curdwg curdoc)
  (vl-load-com)
  ;;timer function due to Jon Fleming
  (defun timer (base /)
    (if base
     (rtos (* 86400.0 (- (getvar "DATE") base)) 2 4)
     (getvar "DATE")
    );if
  );timer
  (initget "Yes No")
  (setq single (getkword "\nPurge One-Entity Groups? Yes/No <Yes>"))
  ;;use active x methods to get file information
  (setq curdoc (vla-get-activedocument (vlax-get-acad-object))
        size (vl-file-size (setq curdwg (vla-get-fullname curdoc))))
  (vla-save curdoc);save the doc to get accurate file size
  (textscr)
  (setq base (timer nil))
  (if (or (null single) (= single "Yes"))
    (princ (strcat "\nPurged " (itoa(purgegroups T)) " Groups."))
    (princ (strcat "\nPurged " (itoa(purgegroups nil)) " Groups."))
  )
  (princ (strcat "\nElapsed Time = " (timer base) " sec."))
  (princ "\nFile Size: ")
  (princ (strcat "\nGroups Unpurged: " (itoa size)))
  (vla-save curdoc);save again to query file size
  (textscr);vla-save hides text screen
  (princ (strcat "\nGroups Purged:   " (itoa (vl-file-size curdwg))))
  ;;but an odd thing is the file size grows by 1-2 bytes if zero groups purged!
  (princ)
);C:Purgegroups
;;load prompts
(princ "\nPurgegroups V1.1 © 2003 Herman Mayfarth")
(princ "\nType LISTGROUPS for Group Info, PURGEGROUPS to Purge.")
(princ)