[原创]遍历图形，用不重复数组技术，找出图形中有多少类型实体。

兰州人 · 发表于 2008-3-31 15:03:00

遍历图形中共有 56 (n)个实体类型
不重复排序后，图形中有  6 种类型实体
分别是
1          AcDbRotatedDimension
2          AcDbMText
3          AcDbLine
4          AcDbZombieEntity
5          AcDbRadialDimension
6          AcDbArc
程序如下

copy


Sub ls()
  Dim Ent As AcadEntity
  Dim SelectEntityArray() As String, ReturnEntityArray() As Variant
  ReDim SelectEntityArray(ThisDrawing.ModelSpace.Count - 1) As String
  ii = 0
  For ii = 0 To ThisDrawing.ModelSpace.Count - 1
    SelectEntityArray(ii) = ThisDrawing.ModelSpace.Item(ii).ObjectName
  Next ii
  Debug.Print TypeName(SelectEntityArray)
  ReturnEntityArray = NoRepeatArray(SelectEntityArray)
  
  Debug.Print "图形中共有", ThisDrawing.ModelSpace.Count, "个实体类型"
  Debug.Print "不重复排序后，图形中有", UBound(ReturnEntityArray), "实体类型"
  'Debug.Print "1222222222   ", UBound(NoRepeatArray(SelectEntityArray))
  Debug.Print
  For ii = 1 To UBound(ReturnEntityArray)
    Debug.Print ii, ReturnEntityArray(ii)
  Next ii
End Sub
Function NoRepeatArray(xm) 'As Variant()
    Dim Arr, Temp() As String '声明变量
    Dim s%, r% '声明单值变量
    On Error Resume Next '启动一个错误处理程序
     
    r = 0 '初值
    s = UBound(xm) '最大下标
    ReDim Arr(s - 1)
    For I = 0 To s '循环
        Temp = Filter(Arr, xm(I)) '搜索数组
        If UBound(Temp) = -1 Then '如果未找到
            r = r + 1 '序号，自增1
            ReDim Preserve Arr(1 To r)  '定义动态数组大小
            Arr(r) = xm(I) '把姓名复制到数组Arr()中。
        End If
    Next
    NoRepeatArray = Arr
    
End Function

----------------------
Sub ls()
  Dim Ent As AcadEntity
  Dim SelectEntityArray() As String, ReturnEntityArray() As Variant
  ReDim SelectEntityArray(ThisDrawing.ModelSpace.Count - 1) As String
  ii = 0
  For ii = 0 To ThisDrawing.ModelSpace.Count - 1
SelectEntityArray(ii) = ThisDrawing.ModelSpace.Item(ii).ObjectName
  Next ii
  Debug.Print TypeName(SelectEntityArray)
  ReturnEntityArray = NoRepeatArray(SelectEntityArray)

  Debug.Print "图形中共有", ThisDrawing.ModelSpace.Count, "个实体类型"
  Debug.Print "不重复排序后，图形中有", UBound(ReturnEntityArray), "实体类型"
  'Debug.Print "1222222222 ", UBound(NoRepeatArray(SelectEntityArray))
  Debug.Print
  For ii = 1 To UBound(ReturnEntityArray)
Debug.Print ii, ReturnEntityArray(ii)
  Next ii
End Sub
Function NoRepeatArray(xm) 'As Variant()
Dim Arr, Temp() As String '声明变量
Dim s%, r% '声明单值变量
On Error Resume Next '启动一个错误处理程序

r = 0 '初值
s = UBound(xm) '最大下标
ReDim Arr(s - 1)
For I = 0 To s '循环
      Temp = Filter(Arr, xm(I)) '搜索数组
      If UBound(Temp) = -1 Then '如果未找到
         r = r + 1 '序号，自增1
         ReDim Preserve Arr(1 To r)  '定义动态数组大小
         Arr(r) = xm(I) '把姓名复制到数组Arr()中。
      End If
Next
NoRepeatArray = Arr

End Function