实体不重复排序
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发表于2007-12-18 18:19:00static/image/common/back.gif这好象只是名称排序，而不是位置排序。
<p>数千个实体数据经过归纳合并数据处理后，得出以下结果。</p><p>AcDbHatch<br/>AcDbLine<br/>AcDbMText<br/>AcDbPolyline<br/>AcDbSolid</p><p>读上述实体属性数据，传送数据到数据库中，进行后续处理。</p><p><br/></p> <p>Function xlApp() As Object</p><p>' Dim xlApp As Object ' This Line ,Not set Excel , run Excel<br/> 'Dim xlsheet As Object<br/> <br/> ' 发生错误时跳到下一个语句继续执行<br/> On Error Resume Next<br/> ' 连接Excel应用程序<br/> Set xlApp = GetObject(, "Excel.Application")<br/> <br/> If Err.Number <> 0 Then<br/> Set xlApp = CreateObject("Excel.Application")<br/> xlApp.Visible = True<br/> xlApp.Workbooks.Add<br/> End If<br/> ' 返回当前活动的工作表<br/>End Function</p><p>Sub labc()<br/> Dim xlSheet<br/> Set ArcXlsheet = xlApp.sheets(1)<br/> ArcXlsheet.Name = "Arc"<br/> Set CircleXlSheet = xlApp.sheets(2)<br/> CircleXlSheet.Name = "Circle"<br/> Set PolylineXlSheet = xlApp.sheets(3)<br/> PolylineXlSheet.Name = "Polyline"<br/> Set LineXlSheet = xlApp.sheets.Add<br/> LineXlSheet.Name = "Line"<br/> Set MTextXlSheet = xlApp.sheets.Add<br/> MTextXlSheet.Name = "MText"<br/> Set TextXlSheet = xlApp.sheets.Add<br/> TextXlSheet.Name = "Text"<br/>' Dim Set<br/> Dim DbArc As AcadArc, DbCircle As AcadCircle<br/> Dim DbDiametricDimension As AcadDimDiametric, DbLeader As AcadLeader<br/> Dim DbLine As AcadLine, DbMText As AcadMText<br/> Dim DbPolyline As AcadPolyline, DbRotatedDimension As AcadDimRotated<br/> Dim DbSolid As AcadSolid, Ent As AcadEntity<br/> iiArc = 1<br/> For Each Ent In ThisDrawing.ModelSpace<br/> Select Case Ent.ObjectName<br/> Case "AcDbArc"<br/> Set DbArc = Ent<br/> ArcXlsheet.Cells(iiArc, 1) = DbArc.Center(0): ArcXlsheet.Cells(iiArc, 2) = DbArc.Center(1)<br/> iiArc = iiArc + 1<br/> End Select<br/> Next Ent<br/> ArcXlsheet.Select<br/>End Sub</p> 我有桩排序 呵呵。
页:
[1]