[求助]Group的問題

GordonHong

AutoCAD 2002 里的Group(或-Group),无论是新增或是解除群组,都必须给一个群组的名称,
若不知道有时用起来很不方便,有没有方法可以不用记群组的名称呢.在2000版里没有这方面
的问题,因为它不需要名称.

mccad

' 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("*")
    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
    Debug.Print UnNameGroup.ObjectName
    Debug.Print UnNameGroup.ObjectID
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
    End If
    Set GetSelSet = ss
End Function

mccad

(vl-load-com)
;;自动加载VBA程序的函数
(defun AutoVBALoad (cmdname project macro)
  (eval
    (list 'defun
          (read (strcat "C:" cmdname))
          nil
          (list
            'vl-vbarun
            (strcat
              project
              "!"
              (if macro
                macro
                cmdname
              )
            )
          )
          (princ)
    )
  )
)

(AutoVBALoad "DG" "UnNameGroup.dvb" "DelUnNameGroup")
(AutoVBALoad "AG" "UnNameGroup.dvb" "AddUnNameGroup")

myfreemind

这么好的帖沉下去真可惜！顶起来！