For what it's worth, here's my code for creating and editing groups. It's a bit of a mess but you get that when you're in a hurry
There is no doubt a few areas that need more error checking/handling but it works.
The idea is to be able to create groups of parts (assemblies) and these groups can not contain parts of other groups. When removing parts from the group you can't delete the 'main' or first part as it is the parent of the assembly if you like.
You can create, explode, add to and remove, hide a group and display all groups.
I'm going to take a quick look at creating groups of groups so you can hide an area/section of the model as needed, these groups have to be different to normal groups, the way I'm looking at doing this is with the 'selectable' property, we'll see.
Public Sub GroupFromEnt(group As AcadGroup, ent As AcadEntity, exists As Boolean)
' Get the groups, sets the group object if found.
Dim groups As acadGroups, groupEntity As AcadEntity
Dim length As Integer
Dim i As Integer
Set groups = ThisDrawing.groups
' Iterate all available groups
For Each group In groups
length = group.Count
'Get every entity from a group
For i = 0 To length - 1
Set groupEntity = group.Item(i)
If groupEntity.Handle = ent.Handle Then
exists = True
'let's go, we got it:
Exit Sub
End If
Next i
Next
End Sub
Public Function IsInAGroup(ent As AcadEntity) As Boolean
'given an entity, it checks to see if it belongs to a group.
' Get the groups
Dim group As AcadGroup, groups As acadGroups, groupEntity As AcadEntity
Dim length As Integer
Dim i As Integer
Set groups = ThisDrawing.groups
' Iterate all available groups
For Each group In groups
length = group.Count
'Get every entity from a group
For i = 0 To length - 1
Set groupEntity = group.Item(i)
If groupEntity.Handle = ent.Handle Then
IsInAGroup = True
'let's go, we got it:
Exit Function
End If
Next i
Next
IsInAGroup = False
End Function
'************** Group user stuff *****************************'
Public Sub CreateGroup()
Dim strName As String
Dim returnObj As Object
Dim basePnt As Variant
On Error GoTo Exit_Error
ThisDrawing.Utility.GetEntity returnObj, basePnt, _
"Select the main part for the group: "
'get the main part for the group, check to make sure it's a 3d solid:
While returnObj.ObjectName <> "AcDb3dSolid"
ThisDrawing.Utility.GetEntity returnObj, basePnt, _
"Select the main part for the group: "
Wend
Dim group As AcadGroup, groups As acadGroups
Dim isInGroup As Boolean
'check if it's in a group already:
GroupFromEnt group, returnObj, isInGroup
If isInGroup = True Then
'group exists, lets leave:
ThisDrawing.Utility.Prompt "Object is already in a group!"
Exit Sub
End If
'if we got the part, get the group name from the user:
Dim groupName As String
groupName = ThisDrawing.Utility.GetString _
(0, vbCrLf & "Enter group name (Press enter to accept default): ")
Set groups = ThisDrawing.groups
If groupName = "" Then
'create the group using obj's handle for name:
Set group = groups.Add(returnObj.Handle)
Else
'create the group with the user name:
Set group = groups.Add(groupName)
End If
'ask the user if they want to add any further parts to the group:
Dim SS1 As AcadSelectionSet
Dim FilterType1(0 To 0) As Integer
Dim FilterData1(0 To 0) As Variant
FilterType1(0) = 0
FilterData1(0) = "3DSOLID"
Set SS1 = vbdPowerSet("SS1")
Dim keyWord As String
ThisDrawing.Utility.InitializeUserInput 0, "Yes No"
keyWord = ThisDrawing.Utility.GetKeyword _
(vbCrLf & "Do you want ot add parts to this group (Yes/No <No>): ")
If keyWord = "" Then keyWord = "No"
If keyWord = "Yes" Then 'if no, the sset count will be 0
SS1.SelectOnScreen FilterType1, FilterData1
End If
'if yes, add them to the new group:
Dim tmpgroup As AcadGroup, solid As AcadEntity
Dim objs() As AcadEntity
'set up the array to take what's left:
ReDim objs(SS1.Count)
'add the main part to the new group:
Set objs(0) = returnObj
'now add the rest from the sset:
Dim i As Integer
i = 1 'we already added the first object, start at one.
If SS1.Count <> 0 Then
For Each solid In SS1
If IsInAGroup(solid) <> True Then
If solid.Handle <> returnObj.Handle Then
Set objs(i) = solid
i = i + 1
End If
End If
Next
End If
'add the objs to the group:
ReDim Preserve objs(i - 1)
group.AppendItems objs
Exit_Here:
Exit Sub
Exit_Error:
Select Case Err.Number
Case -2145386494 'not applicable
Resume Next
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Sub
Public Sub ExplodeGroup()
'deletes a group from the groups collection
Dim group As AcadGroup, exists As Boolean
'get the group from the user
Dim returnObj As Object
Dim basePnt As Variant
ThisDrawing.Utility.GetEntity returnObj, basePnt, _
"Select group to explode: "
GroupFromEnt group, returnObj, exists
If exists = True Then
ThisDrawing.groups.Item(group.Name).Delete
End If
End Sub
Public Sub AddToGroup()
'deletes a group from the groups collection
Dim group As AcadGroup, exists As Boolean
'get the group from the user
Dim returnObj As Object
Dim basePnt As Variant
On Error GoTo Exit_Error
ThisDrawing.Utility.GetEntity returnObj, basePnt, _
"Select group to add items to: "
GroupFromEnt group, returnObj, exists
If exists = False Then
ThisDrawing.Utility.Prompt "Object is not a group!"
Exit Sub
End If
'must be a group, get items to add:
Dim SS1 As AcadSelectionSet
Dim FilterType1(0 To 0) As Integer
Dim FilterData1(0 To 0) As Variant
FilterType1(0) = 0
FilterData1(0) = "3DSOLID"
Set SS1 = vbdPowerSet("SS1")
SS1.SelectOnScreen FilterType1, FilterData1
Dim i As Integer, solid As AcadEntity
Dim objs() As AcadEntity
ReDim objs(SS1.Count - 1)
i = 0
If SS1.Count <> 0 Then
For Each solid In SS1
If IsInAGroup(solid) <> True Then
Set objs(i) = solid
i = i + 1
End If
Next
End If
'add the objs (if any) to the group:
ReDim Preserve objs(i - 1)
group.AppendItems objs
Exit_Here:
Exit Sub
Exit_Error:
Select Case Err.Number
Case -2145386494 'not applicable
Resume Next
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Sub
Public Sub RemoveFromGroup()
'removes selected items from a selected group.
Dim group As AcadGroup, exists As Boolean
'get the group from the user
Dim returnObj As Object
Dim basePnt As Variant
On Error GoTo Exit_Error
'check pickstyle so we don't pick groups:
Dim pstyle As Integer
pstyle = ThisDrawing.GetVariable("PICKSTYLE")
If pstyle = 1 Then
ThisDrawing.SetVariable "PICKSTYLE", 0
End If
ThisDrawing.Utility.GetEntity returnObj, basePnt, _
"Select group to remove items from: "
GroupFromEnt group, returnObj, exists
If exists = False Then
ThisDrawing.Utility.Prompt "Object is not a group!"
Exit Sub
End If
'must be a group, get items to remove:
Dim SS1 As AcadSelectionSet
Dim FilterType1(0 To 0) As Integer
Dim FilterData1(0 To 0) As Variant
FilterType1(0) = 0
FilterData1(0) = "3DSOLID"
Set SS1 = vbdPowerSet("SS1")
SS1.SelectOnScreen FilterType1, FilterData1
Dim i As Integer, solid As AcadEntity
Dim objs() As AcadEntity
ReDim objs(SS1.Count - 1)
i = 0
If SS1.Count <> 0 Then
For Each solid In SS1
'we don't want to remove the main part of the group:
If solid.Handle <> group.Item(0).Handle Then
Set objs(i) = solid
i = i + 1
End If
Next
End If
'remove the objs (if any) to the group:
If i > 0 Then
ReDim Preserve objs(i - 1)
group.RemoveItems objs
End If
'reset pickstyle:
ThisDrawing.SetVariable "PICKSTYLE", pstyle
Exit_Here:
ThisDrawing.SetVariable "PICKSTYLE", pstyle
Exit Sub
Exit_Error:
Select Case Err.Number
Case -2145386494 'not applicable
Resume Next
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Sub
Public Sub HideGroup()
'hides a selected group.
Dim group As AcadGroup, exists As Boolean
'get the group from the user
Dim returnObj As Object
Dim basePnt As Variant
On Error GoTo Exit_Error
ThisDrawing.Utility.GetEntity returnObj, basePnt, _
"Select group to hide: "
GroupFromEnt group, returnObj, exists
If exists = False Then
ThisDrawing.Utility.Prompt "Object is not a group!"
Exit Sub
End If
group.Visible = False
Exit_Here:
Exit Sub
Exit_Error:
Select Case Err.Number
Case -2145386494 'not applicable
Resume Next
Case Else
MsgBox Err.Description
Resume Exit_Here
End Select
End Sub
Public Sub DisplayGroups()
'iterates the groups collection and makes them all visible:
Dim group As AcadGroup, groups As acadGroups
Set groups = ThisDrawing.groups
For Each group In groups
group.Visible = True
Next
End Sub
<edit> fixed prompts so they made sense