录找CAD -GROUP 超级命令

steven8386 · 发表于 2008-5-3 11:36:00

用group创建组的时候，需要输入实名设置，但是我想一少到位的，像CAD LT版本中的group一样，现在编组我刚弄好了，但是解组还是不行！

编组：-group ; ;* ;*\

但是解组就弄不出来了，请各位帮忙看看，要不然的话，帮我写个加载应用程序也可以的！

我用的是CAD2009版本的！

谢谢！

geraldxyz · 发表于 2008-5-26 15:03:00

在晓东里找到一个这样的帖子，似乎和你的要求沾点边：http://www.xdcad.net/forum/showthread.php?s=&postid=894063#post894063

但是不知道怎么加载：附代码如下：

回复:
最初由 chenhang 发布
请问怎么把组分解开
因为我图中的组都没有命名，而且有很多组，如果把要分解的组在GROUP的菜单中找出来再分解很麻烦。有什么命令可以直接分解组。就象炸开块一样？

这是别人写的，借花献佛

代码:


  
'将选定的组合分解开
'由于不能通过选定的对象来直接找到其组合名称，只能通过循环比较对象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 <> 0 Then
           Err.Clear
           Set ss = ThisDrawing.SelectionSets.Add(ssName)
        End If
        ss.Clear
        ss.SelectOnScreen
    End If
    Set GetSelSet = ss
End Function


  
'将选定的组合分解开
'由于不能通过选定的对象来直接找到其组合名称，只能通过循环比较对象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 <> 0 Then
           Err.Clear
           Set ss = ThisDrawing.SelectionSets.Add(ssName)
        End If
        ss.Clear
        ss.SelectOnScreen
    End If
    Set GetSelSet = ss
End Function

如果楼主知道怎么用了还望告知一声啊：）

向版主反映该贴 | IP: 已记录

claotlaot · 发表于 2008-6-29 18:21:00

不明白怎么使用

账号		自动登录	找回密码
密码			注册