给个vba的函数,用了匿名group,好用
'将选定的对象组合 Sub ag() On Error Resume Next Dim SelObjects As AcadSelectionSet Set SelObjects = GetSelSet Dim UnNameGroup As AcadGroup 'On Error Resume Next Set UnNameGroup = ThisDrawing.Groups.Add("*") ReDim appendObjs(0 To SelObjects.count - 1) As AcadEntity Dim i As Integer For i = 0 To SelObjects.count - 1 Set appendObjs(i) = SelObjects.Item(i) Next
UnNameGroup.AppendItems appendObjs SelObjects.Delete End Sub
'将选定的组合分解开 '由于不能通过选定的对象来直接找到其组合名称,只能通过循环比较对象ID的方法 '来解决这个问题,运行时可能会慢点,但对象不多的情况下应该没问题 Sub Dg()
Dim SelGroup As AcadGroup Dim SelObjects As AcadSelectionSet Set SelObjects = GetSelSet Dim ObjInSelSet As AcadObject Dim i As Integer Dim j As Integer Dim k As Integer Dim ObjInGroup As AcadObject On Error Resume Next For i = 0 To SelObjects.count - 1 Set ObjInSelSet = SelObjects.Item(i) For j = 0 To ThisDrawing.Groups.count - 1 For k = 0 To ThisDrawing.Groups.Item(j).count - 1 Set ObjInGroup = ThisDrawing.Groups.Item(j).Item(k) If ObjInGroup.ObjectID = ObjInSelSet.ObjectID Then ThisDrawing.Groups.Item(j).Delete Exit For End If Next Next Next SelObjects.Delete End Sub
'对象选择函数 Function GetSelSet() As AcadSelectionSet Dim ss As AcadSelectionSet Set ss = ThisDrawing.PickfirstSelectionSet On Error Resume Next If ss.count = 0 Then Dim ssName As String ssName = "str1SSet" On Error Resume Next Set ss = ThisDrawing.SelectionSets(ssName) If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName) ss.Clear ss.SelectOnScreen End If Set GetSelSet = ss End Function