实体不重复排序
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 FunctionFunction 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
这好象只是名称排序，而不是位置排序。
数千个实体数据经过归纳合并数据处理后，得出以下结果。
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.Number0 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
我有桩排序 呵呵。
页:
[1]