社区 › VBA/VB/ActiveX/API 编程技术 › 请教一个关于组的命令

shaobaohai 发表于 2008-1-19 16:27:00

请教一个关于组的命令

<p>autocad中有一个关于组选择的命令ctrl+shift+a，对组的使用很方便，</p><p>但是，我感觉这个组合使用起来太麻烦，想用VBA编一个命令实现它，</p><p>请指点一下。</p><p>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; 谢谢！</p>

mccad 发表于 2008-1-19 20:34:00

5年前的程序，但好用。
' 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 发表于 2008-1-21 09:58:00

<p>上面的程序我也有</p><p>但是对于大的组操作起来太慢了，</p><p>没有简单的吗</p>

查看完整版本: 请教一个关于组的命令