|
|
发表于 2004-8-5 20:49:00
|
显示全部楼层
你的图是Group形式，考虑组字典是否会好处理些, 今天写了个vba的程序,有些牵强:
'就你的dwg文件而言,你需要得到的鞋样板片都是以组Group形式存在的.
'而开孔实体没有,仍然是Spline.
'所以这个程序只对这两张图. 如果开孔实体也是在Group中,就要再想别的方法了!
Sub Test()
Dim ssetObj As AcadSelectionSet
Dim SSetColl As AcadSelectionSets
Set SSetColl = ThisDrawing.SelectionSets
Set ssetObj = CreateSSet("TEST2")
Dim mode As Integer
mode = acSelectionSetAll
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = "SPLINE"
Dim groupCode As Variant
Dim dataCode As Variant
groupCode = gpCode
dataCode = dataValue
ssetObj.Select acSelectionSetAll, , , groupCode, dataCode
'取得选择集中所有Spline实体ID
Dim ssObj As AcadEntity
Dim ind As Integer
Dim idlist() As Long
ReDim idlist(0)
For ind = 0 To ssetObj.Count - 1
Set ssObj = ssetObj.Item(ind)
If StrComp(ssObj.ObjectName, "AcDbSpline", 1) = 0 Then
ReDim Preserve idlist(UBound(idlist) + 1)
idlist(UBound(idlist)) = ssObj.ObjectID
End If
Next
'''
Dim groupsObj As AcadGroups
Set groupsObj = ThisDrawing.Groups
Dim groupObj As AcadGroup
Dim num As Integer 'Group个数计数据器
num = 0
Dim i, j As Integer
For i = 0 To groupsObj.Count - 1
Set groupObj = groupsObj.Item(i)
Dim na As String
na = groupObj.name
Dim Count As Integer
Count = groupObj.Count
If Count > 0 Then
Dim grpEnt As AcadEntity
'检查每一个Group中有无idlist()数组中列出的实体
For j = 0 To Count - 1
Set grpEnt = groupObj.Item(j)
Dim entName As String
entName = grpEnt.ObjectName
If StrComp(entName, "AcDbSpline", 0) = 0 Then
Dim entId As Long
entId = grpEnt.ObjectID
'在idlist中查找有无entId,如果有,我就认为这个Group是一个鞋样(当然不具有普适性)
Dim il As Integer
Dim found As Boolean
found = False
For il = 1 To UBound(idlist)
If entId = idlist(il) Then
found = True
Exit For
End If
Next
If (found = True) Then
num = num + 1 '计数器
Exit For
End If
End If
Next '
End If
Next
MsgBox num
End Sub
Private Function CreateSSet(ByVal name As String) As AcadSelectionSet
On Error GoTo ERR_HANDLER
Dim ssetObj As AcadSelectionSet
Dim SSetColl As AcadSelectionSets
Set SSetColl = ThisDrawing.SelectionSets
Dim index As Integer
Dim found As Boolean
found = False
For index = 0 To SSetColl.Count - 1
Set ssetObj = SSetColl.Item(index)
If StrComp(ssetObj.name, name, 1) = 0 Then
found = True
Exit For 'Important.
End If
Next
If Not (found) Then
Set ssetObj = SSetColl.Add(name)
Else
ssetObj.Delete '
Set ssetObj = SSetColl.Add(name)
End If
Set CreateSSet = ssetObj
Exit Function
ERR_HANDLER:
'-----------------------------------------------
' just print the error the the debug window.
Debug.Print "Error in sub CreateSSet: " & Err.Number & " -- "; Err.Description
Resume ERR_END
ERR_END:
End Function
|
|
置顶卡
请点击此处下载
