请教一个关于组的命令

shaobaohai

AutoCAD中有一个关于组选择的命令ctrl+shift+a，对组的使用很方便，

但是，我感觉这个组合使用起来太麻烦，想用VBA编一个命令实现它，

请指点一下。

       谢谢！

mccad

5年前的程序，但好用。

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

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

shaobaohai

上面的程序我也有

但是对于大的组操作起来太慢了，

没有简单的吗