;-------------------------------------------------------------------------------
; Program Name: Groups.lsp [Groups R2]
; Created By:   Terry Miller (Email: terrycadd@yahoo.com)
;               (URL: http://web2.airmail.net/terrycad)
; Date Created: 2-20-06
; Function:     Several functions to create, explode, and purge unused groups
;               quickly. It also includes the function UniqueName, which creates
;               a unique name based upon the date and time it was created.
;-------------------------------------------------------------------------------
; Revision History
; Rev  By     Date    Description
;-------------------------------------------------------------------------------
; 1    TM   2-20-06   Initial version.
; 2    TM   6-20-06   Revised c:PUG Purge Unused Groups function.
;-------------------------------------------------------------------------------
; c:GP - Creates a Group
;-------------------------------------------------------------------------------
(defun c:GP (/ GroupName$ SS&)
  (princ "\nSelect objects to create a group: ")
  (if (setq SS& (ssget))
    (progn
      (setq GroupName$ (UniqueName))
      (command "-GROUP" "C" GroupName$ "" SS& "")
      (princ (strcat "\nGroup " GroupName$ " created."))
    );progn
    (princ "\nNo objects selected.")
  );if
  (princ)
);defun c:GP
;-------------------------------------------------------------------------------
; c:XGP - Explodes a Group
;-------------------------------------------------------------------------------
(defun c:XGP (/ Dictionary^ EntList@ EntName^ Group^ GroupName$ Item Previous$)
  (princ "\nSelect group to explode: ")
  (if (setq EntName^ (car (entsel)))
    (progn
      (setq EntList@ (entget EntName^))
      (if (= (cdr (assoc 102 EntList@)) "{ACAD_REACTORS")
        (progn
          (setq Group^ (cdr (assoc 330 EntList@)))
          (if (setq EntList@ (entget Group^))
            (progn
              (setq Dictionary^ (cdr (assoc 330 EntList@)))
              (setq EntList@ (entget Dictionary^))
              (foreach Item EntList@
                (setq Item (cdr Item))
                (if (equal Item Group^)
                  (setq GroupName$ Previous$)
                );if
                (setq Previous$ Item)
              );foreach
              (if GroupName$
                (command "-GROUP" "E" GroupName$)
              );if
            );progn
          );if
        );progn
      );if
      (if GroupName$
        (princ (strcat "\nGroup " GroupName$ " exploded."))
        (princ "\nObject selected was not part of a group.")
      );if
    );progn
    (princ "\nNo object selected.")
  );if
  (princ)
);defun c:XGP
;-------------------------------------------------------------------------------
; c:PUG - Purge Unused Groups
;-------------------------------------------------------------------------------
(defun c:PUG (/ AllGroups@ Cnt# Dictionary^ EntFirst^ EntList@ FirstGroup$ Group^
  GroupName$ Item Previous$ Pt SS& UsedGroups@)
  (princ "\nPurge Unused Groups\n")
  (setq Pt (polar (getvar "VIEWCTR") (* pi 1.5)(/ (getvar "VIEWSIZE") 2.0)))
  (command "LINE" Pt (polar Pt 0 (/ (getvar "VIEWSIZE") 1000.0)) "")
  (setq EntFirst^ (entlast))
  (setq FirstGroup$ (UniqueName))
  (command "GROUP" "C" FirstGroup$ "" EntFirst^ "")
  (setq EntList@ (entget EntFirst^))
  (setq Group^ (cdr (assoc 330 EntList@)))
  (setq EntList@ (entget Group^))
  (setq Dictionary^ (cdr (assoc 330 EntList@)))
  (setq EntList@ (entget Dictionary^))
  (foreach Item EntList@
    (if (= (car Item) 3)
      (if (not (member (cdr Item) AllGroups@))
        (setq AllGroups@ (append AllGroups@ (list (cdr Item))))
      );if
    );if
  );foreach
  (setq SS& (ssget "X"))
  (setq Cnt# 0)
  (repeat (sslength SS&)
    (setq EntList@ (entget (ssname SS& Cnt#)))
    (if (= (cdr (assoc 102 EntList@)) "{ACAD_REACTORS")
      (progn
        (setq Group^ (cdr (assoc 330 EntList@)))
        (setq EntList@ (entget Group^))
        (if (setq Dictionary^ (cdr (assoc 330 EntList@)))
          (progn
            (setq EntList@ (entget Dictionary^))
            (foreach Item EntList@
              (setq Item (cdr Item))
              (if (equal Item Group^)
                (setq GroupName$ Previous$)
              );if
              (setq Previous$ Item)
            );foreach
            (if (not (member GroupName$ UsedGroups@))
              (setq UsedGroups@ (append UsedGroups@ (list GroupName$)))
            );if
          );progn
        );if
      );progn
    );if
    (setq Cnt# (1+ Cnt#))
  );repeat
  (foreach GroupName$ AllGroups@
    (if (not (member GroupName$ UsedGroups@))
      (command "-GROUP" "E" GroupName$)
    );if
  );foreach
  (command "-GROUP" "E" FirstGroup$)
  (command "ERASE" EntFirst^ "")
  (princ)
);defun c:PUG
;-------------------------------------------------------------------------------
; GP - Function to create a group
;-------------------------------------------------------------------------------
(defun GP (SS& / GroupName$)
  (setq GroupName$ (UniqueName))
  (command "-GROUP" "C" GroupName$ "" SS& "")
  (princ)
);defun GP
;-------------------------------------------------------------------------------
; UniqueName - Creates a unique name for temp blocks and groups
;-------------------------------------------------------------------------------
(defun UniqueName (/ Loop Name$)
  (setq Loop t)
  (while Loop
    (setq Name$ (rtos (getvar "CDATE") 2 8))
    (setq Name$ (strcat (substr Name$ 4 5)(substr Name$ 10 8)))
    (if (/= Name$ *UniqueName$)
      (setq *UniqueName$ Name$ Loop nil)
    );if
  );while
  *UniqueName$
);defun UniqueName
;-------------------------------------------------------------------------------
(princ)