实体不重复排序

兰州人

2. Sub ls()
3.   Dim xm1(), abc(), Gggg()
4.   Dim Ent As AcadEntity
5.   Dim AllEntityArray, AllEntityCount As Integer
6.   AllEntityCount = ThisDrawing.ModelSpace.Count
7.   ReDim AllEntityArray(AllEntityCount - 1)
8.   For ii = 0 To AllEntityCount - 1
9.     With ThisDrawing.ModelSpace.Item(ii)
10.       AllEntityArray(ii) = .ObjectName
11.     End With
12.   Next ii
13.   abc = NoRepeatArray(AllEntityArray) '不重复数组处理
14.   Gggg = Bubble_Sort(abc)
15.   For ii = 1 To UBound(Gggg) - 1
16.     Debug.Print Gggg(ii)
17.   Next ii
18.   Debug.Print
19. End Sub
20. Function Bubble_Sort(Ary)
21.    Dim aryUBound, i, j
22.    aryUBound = UBound(Ary)
23.    For i = 1 To aryUBound
24.      For j = i + 1 To aryUBound
25.        If Ary(i) > Ary(j) Then
26.          Swap Ary(i), Ary(j)
27.        End If
28.      Next
29.    Next
30.    Bubble_Sort = Ary
31. End Function
32. Function Swap(a, b)
33.    Dim tmp
34.    tmp = a
35.    a = b
36.    b = tmp
37. End Function
39. Function NoRepeatArray(xm)
40.     Dim Arr(), Temp() As String '声明变量
41.     Dim s%, r% '声明单值变量
42.     On Error Resume Next '启动一个错误处理程序
43.    
44.     r = 0 '初值
45.     s = UBound(xm) '最大下标
46.     For i = 0 To s '循环
47.         Temp = Filter(Arr, xm(i)) '搜索数组
48.         If UBound(Temp) = -1 Then '如果未找到
49.             r = r + 1 '序号，自增1
50.             ReDim Preserve Arr(1 To r) '定义动态数组大小
51.             Arr(r) = xm(i) '把姓名复制到数组Arr()中。
52.         End If
53.     Next
54.     NoRepeatArray = Arr
55. End Function

Sub ls()   Dim xm1(), abc(), Gggg()   Dim Ent As AcadEntity   Dim AllEntityArray, AllEntityCount As Integer   AllEntityCount = ThisDrawing.ModelSpace.Count   ReDim AllEntityArray(AllEntityCount - 1)   For ii = 0 To AllEntityCount - 1     With ThisDrawing.ModelSpace.Item(ii)       AllEntityArray(ii) = .ObjectName     End With   Next ii   abc = NoRepeatArray(AllEntityArray) '不重复数组处理   Gggg = Bubble_Sort(abc)   For ii = 1 To UBound(Gggg) - 1     Debug.Print Gggg(ii)   Next ii   Debug.Print End Sub Function Bubble_Sort(Ary)    Dim aryUBound, i, j    aryUBound = UBound(Ary)    For i = 1 To aryUBound      For j = i + 1 To aryUBound        If Ary(i) > Ary(j) Then          Swap Ary(i), Ary(j)        End If      Next    Next    Bubble_Sort = Ary End Function Function Swap(a, b)    Dim tmp    tmp = a    a = b    b = tmp End Function Function NoRepeatArray(xm)     Dim Arr(), Temp() As String '声明变量     Dim s%, r% '声明单值变量     On Error Resume Next '启动一个错误处理程序         r = 0 '初值     s = UBound(xm) '最大下标     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

mccad

这好象只是名称排序，而不是位置排序。

兰州人

mccad发表于2007-12-18 18:19:00这好象只是名称排序，而不是位置排序。

数千个实体数据经过归纳合并数据处理后，得出以下结果。

AcDbHatch
AcDbLine
AcDbMText
AcDbPolyline
AcDbSolid

读上述实体属性数据，传送数据到数据库中，进行后续处理。

兰州人

Function xlApp() As Object

'  Dim xlApp As Object    ' This Line ,Not set Excel , run Excel
     'Dim xlsheet As Object
    
     ' 发生错误时跳到下一个语句继续执行
     On Error Resume Next
     ' 连接Excel应用程序
     Set xlApp = GetObject(, "Excel.Application")
    
     If Err.Number <> 0 Then
         Set xlApp = CreateObject("Excel.Application")
         xlApp.Visible = True
         xlApp.Workbooks.Add
     End If
     ' 返回当前活动的工作表
End Function

Sub labc()
  Dim xlSheet
  Set ArcXlsheet = xlApp.sheets(1)
  ArcXlsheet.Name = "Arc"
  Set CircleXlSheet = xlApp.sheets(2)
  CircleXlSheet.Name = "Circle"
  Set PolylineXlSheet = xlApp.sheets(3)
  PolylineXlSheet.Name = "Polyline"
  Set LineXlSheet = xlApp.sheets.Add
  LineXlSheet.Name = "Line"
  Set MTextXlSheet = xlApp.sheets.Add
  MTextXlSheet.Name = "MText"
  Set TextXlSheet = xlApp.sheets.Add
  TextXlSheet.Name = "Text"
' Dim Set
  Dim DbArc As AcadArc, DbCircle As AcadCircle
  Dim DbDiametricDimension As AcadDimDiametric, DbLeader As AcadLeader
  Dim DbLine As AcadLine, DbMText As AcadMText
  Dim DbPolyline As AcadPolyline, DbRotatedDimension As AcadDimRotated
  Dim DbSolid As AcadSolid, Ent As AcadEntity
  iiArc = 1
  For Each Ent In ThisDrawing.ModelSpace
    Select Case Ent.ObjectName
      Case "AcDbArc"
       Set DbArc = Ent
       ArcXlsheet.Cells(iiArc, 1) = DbArc.Center(0): ArcXlsheet.Cells(iiArc, 2) = DbArc.Center(1)
       iiArc = iiArc + 1
    End Select
  Next Ent
  ArcXlsheet.Select
End Sub

huiyin

我有桩排序 呵呵。