[分享]：不使用对话框也不需要组合名称，直接选择对象进行组合与分解

wowoaicad

不使用对话框也不需要组合名称，直接选择对象进行组合与分解

2. ' UnNameGroup.dvb
   
3. ' 版权所有 (C) 1999-2003  明经通道 郑立楷
   
4. '
   
5. 'http://www.mjtd.com ; [email]mccad@mjtd.com[/email]
   
6. '
   
7. '   本软件免费可供进行任何用途需求的拷贝、修改及发行, 但请遵循下述原则:
   
8. '
   
9. '   1)  上列的版权通告必须出现在每一份拷贝里。
   
10. '   2)  相关的说明文档也必须载有版权通告及本项许可通告。
    
11. '
    
12. '   本软件仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
    
13. '   用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。
    
14. 
    
15. '软件功能：对象组合及分解
    
16. 
    
17. '该两个程序解决了AutoCAD在对象组合及分解过程中繁琐的操作过程，最主要是在分 _
    
18. 解时不必要首先知道组合的名称，组合时也不需要提供组合名称。
    
19. '该程序可以通过选定对象的方法来组合及分解。
    
20. 
    
21. '将选择对象组合起来
    
22. Sub AddUnNameGroup()
    
23.     Dim SelObjects As AcadSelectionSet
    
24.     Set SelObjects = GetSelSet
    
25.     Dim UnNameGroup As AcadGroup
    
26.     Set UnNameGroup = ThisDrawing.Groups.Add("*")
    
27.     ReDim appendObjs(0 To SelObjects.Count - 1) As AcadEntity
    
28.     Dim I As Integer
    
29.     For I = 0 To SelObjects.Count - 1
    
30.         Set appendObjs(I) = SelObjects.Item(I)
    
31.     Next
    
32.      
    
33.     UnNameGroup.AppendItems appendObjs
    
34. End Sub
    
35. 
    
36. '将选定的组合分解开
    
37. '由于不能通过选定的对象来直接找到其组合名称，只能通过循环比较对象ID的方法
    
38. '来解决这个问题，运行时可能会慢点，但对象不多的情况下应该没问题
    
39. Sub DelUnNameGroup()
    
40. 
    
41.     Dim SelGroup As AcadGroup
    
42.     Dim SelObjects As AcadSelectionSet
    
43.     Set SelObjects = GetSelSet
    
44.     Dim ObjInSelSet As AcadObject
    
45.     Dim I As Integer
    
46.     Dim J As Integer
    
47.     Dim K As Integer
    
48.     Dim ObjInGroup As AcadObject
    
49.     On Error Resume Next
    
50.     For I = 0 To SelObjects.Count - 1
    
51.         Set ObjInSelSet = SelObjects.Item(I)
    
52.         For J = 0 To ThisDrawing.Groups.Count - 1
    
53.             For K = 0 To ThisDrawing.Groups.Item(J).Count - 1
    
54.                 Set ObjInGroup = ThisDrawing.Groups.Item(J).Item(K)
    
55.                 If ObjInGroup.ObjectID = ObjInSelSet.ObjectID Then
    
56.                     ThisDrawing.Groups.Item(J).Delete
    
57.                     Exit For
    
58.                 End If
    
59.             Next
    
60.         Next
    
61.     Next
    
62.                      
    
63. End Sub
    
64. 
    
65. '对象选择函数
    
66. Function GetSelSet() As AcadSelectionSet
    
67.     Dim ss As AcadSelectionSet
    
68.     Set ss = ThisDrawing.PickfirstSelectionSet
    
69.     If ss.Count = 0 Then
    
70.         Dim ssName As String
    
71.         ssName = "strSSet"
    
72.         On Error Resume Next
    
73.         Set ss = ThisDrawing.SelectionSets(ssName)
    
74.         If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    
75.         ss.Clear
    
76.         ss.SelectOnScreen
    
77.     End If
    
78.     Set GetSelSet = ss
    
79. End Function
    

' UnNameGroup.dvb <br /> ' 版权所有 (C) 1999-2003  明经通道 郑立楷 <br /> ' <br /> 'http://www.mjtd.com ; [email]mccad@mjtd.com[/email] <br /> ' <br /> '   本软件免费可供进行任何用途需求的拷贝、修改及发行, 但请遵循下述原则: <br /> ' <br /> '   1)  上列的版权通告必须出现在每一份拷贝里。 <br /> '   2)  相关的说明文档也必须载有版权通告及本项许可通告。 <br /> ' <br /> '   本软件仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊 <br /> '   用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。 <br /> <br /> '软件功能：对象组合及分解 <br /> <br /> '该两个程序解决了AutoCAD在对象组合及分解过程中繁琐的操作过程，最主要是在分 _ <br /> 解时不必要首先知道组合的名称，组合时也不需要提供组合名称。 <br /> '该程序可以通过选定对象的方法来组合及分解。 <br /> <br /> '将选择对象组合起来 <br /> Sub AddUnNameGroup() <br />     Dim SelObjects As AcadSelectionSet <br />     Set SelObjects = GetSelSet <br />     Dim UnNameGroup As AcadGroup <br />     Set UnNameGroup = ThisDrawing.Groups.Add("*") <br />     ReDim appendObjs(0 To SelObjects.Count - 1) As AcadEntity <br />     Dim I As Integer <br />     For I = 0 To SelObjects.Count - 1 <br />         Set appendObjs(I) = SelObjects.Item(I) <br />     Next <br />      <br />     UnNameGroup.AppendItems appendObjs <br /> End Sub <br /> <br /> '将选定的组合分解开 <br /> '由于不能通过选定的对象来直接找到其组合名称，只能通过循环比较对象ID的方法 <br /> '来解决这个问题，运行时可能会慢点，但对象不多的情况下应该没问题 <br /> Sub DelUnNameGroup() <br /> <br />     Dim SelGroup As AcadGroup <br />     Dim SelObjects As AcadSelectionSet <br />     Set SelObjects = GetSelSet <br />     Dim ObjInSelSet As AcadObject <br />     Dim I As Integer <br />     Dim J As Integer <br />     Dim K As Integer <br />     Dim ObjInGroup As AcadObject <br />     On Error Resume Next <br />     For I = 0 To SelObjects.Count - 1 <br />         Set ObjInSelSet = SelObjects.Item(I) <br />         For J = 0 To ThisDrawing.Groups.Count - 1 <br />             For K = 0 To ThisDrawing.Groups.Item(J).Count - 1 <br />                 Set ObjInGroup = ThisDrawing.Groups.Item(J).Item(K) <br />                 If ObjInGroup.ObjectID = ObjInSelSet.ObjectID Then <br />                     ThisDrawing.Groups.Item(J).Delete <br />                     Exit For <br />                 End If <br />             Next <br />         Next <br />     Next <br />                      <br /> End Sub <br /> <br /> '对象选择函数 <br /> Function GetSelSet() As AcadSelectionSet <br />     Dim ss As AcadSelectionSet <br />     Set ss = ThisDrawing.PickfirstSelectionSet <br />     If ss.Count = 0 Then <br />         Dim ssName As String <br />         ssName = "strSSet" <br />         On Error Resume Next <br />         Set ss = ThisDrawing.SelectionSets(ssName) <br />         If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName) <br />         ss.Clear <br />         ss.SelectOnScreen <br />     End If <br />     Set GetSelSet = ss <br /> End Function <br />