社区 › VBA/VB/ActiveX/API 编程技术 › [求助]Group的問題

GordonHong 发表于 2003-2-17 17:55:00

[求助]Group的問題

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

mccad 发表于 2003-2-17 20:40:00

下面是刚写的一个程序，专门用于解决这个问题

' UnNameGroup.dvb
' 版权所有 (C) 1999-2003明经通道 郑立楷
'
' http://www.mjtd.commccad@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 发表于 2003-2-18 16:05:00

自动加载部分(LISP程序)

(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 发表于 2004-5-13 20:56:00

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

查看完整版本: [求助]Group的問題