选择集内的排序问题(高手都来比试一下)
<p>现假设有选择集Sset，其中全为单行文字，由于过滤选择的时候是系统按照其绘图先后顺序而自动添加的，现如何通过其个单行文字的插入点坐标按从从左到右，自上而下的重新排序。此功能用为快速修改页码或图号等，比如一文件中有100幅图，可先查找“第*页”的文字将其添加到Sset中，然后自动修改页码。</p><p>请有兴趣的朋友及高手都来出个主意，怎么样给选择集内的元素排序。</p> <p> </p><p>Dim currInsertionPoint As Variant<br/>currInsertionPoint = textObj.insertionPoint</p><p></p><p>只是比较insertionPoint（０）和insertionPoint（１）的大小问题啊。<br/></p> 我的办法是autocad到EXCEL-SQL排序. fjfhgdwfn发表于2007-11-3 18:51:00static/image/common/back.gif Dim currInsertionPoint As VariantcurrInsertionPoint = textObj.insertionPoint只是比较insertionPoint（０）和insertionPoint（１）的大小问题啊。<p>你考虑问题太简单了，insertionPoint（０）和insertionPoint（１）排序问题可是一个专题了。</p><p>排序，X轴排序，y轴排序。二维数组排序。</p> 利用二维数组的已经是很简单的了，当然你如果只是对文字来排序的话，就可以用这种方法，比大小，自己想想就明白了。我做了一些排序的东西，是针对图框排序的，也是通过点来比较的，但是还不够好，不知道其他人还有什么更好的办法。 看看我这样写对不？
模块：
Public Type Point3d
x As Double
y As Double
z As Double
End Type
代码
Sub RandApt()
'随机布点x=0~1000,y=0~1000
Dim pt As AcadPoint
Dim p() As Double
Dim pl As AcadLWPolyline
Dim i As Integer
ReDim p(7)
p(0) = 0: p(1) = 0
p(2) = 1000: p(3) = 0
p(4) = 1000: p(5) = 1000
p(6) = 0: p(7) = 1000
Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(p)
pl.Closed = True
ThisDrawing.Application.ZoomExtents
ReDim p(2)
For i = 0 To 1000
p(0) = Rnd * 1000
p(1) = Rnd * 1000
Set pt = ThisDrawing.ModelSpace.AddPoint(p)
Next i
End Sub
Sub Sort()
Dim pt As AcadPoint
Dim Ent As AcadEntity
Dim dt() As Point3d
Dim i As Integer
i = -1
For Each Ent In ThisDrawing.ModelSpace
If Ent.ObjectName = "AcDbPoint" Then
Set pt = Ent
i = i + 1
ReDim Preserve dt(i)
dt(i).x = Format(pt.Coordinates(0), "0")
dt(i).y = Format(pt.Coordinates(1), "0.00")
dt(i).z = Format(pt.Coordinates(2), "0.000")
End If
Next
'排序Xy
SSort dt, 2
Open "c:\tmp.txt" For Output As #1
For i = 0 To UBound(dt)
Print #1, dt(i).x, dt(i).y, dt(i).z
Next i
Close #1
Shell "notepad.exe c:\tmp.txt", vbNormalFocus
MsgBox "Over"
End Sub
Function SSort(dt() As Point3d, k As Integer)
'X=1、xy=2、xyz=3
Dim dt1() As Point3d
Dim i As Integer
Dim Ex As Boolean
i = UBound(dt)
ReDim dt1(i)
Dim N As Integer
N = i
dt1(0) = dt(0)
If k >= 1 Then '一次排序
For i = 1 To N
Ex = False
For j = 0 To i - 1
If dt(i).x <= dt1(j).x Then '插入
For k = i To j + 1 Step -1
dt1(k) = dt1(k - 1)
Next k
dt1(j) = dt(i)
Ex = True
Exit For
End If
Next j
If Ex = False Then '追加
dt1(i) = dt(i)
End If
Next i
End If
'==============='===============
If k >= 2 Then '二次排序
Dim tmp As Point3d
x1 = 0: x2 = 0
While x1 <= N
For i = x1 + 1 To N
If dt1(i).x = dt1(x1).x Then
x2 = i
Else
Exit For
End If
Next i
If x2 - x1 > 0 Then
For k = x1 To x2
For j = x1 To x2 - k + x1 - 1
If dt1(j).y > dt1(j + 1).y Then
tmp = dt1(j + 1)
dt1(j + 1) = dt1(j)
dt1(j) = tmp
End If
Next j
Next k
End If
x1 = i
x2 = x1
Wend
End If
'==============='===============
If k >= 3 Then '三次排序
x1 = 0: x2 = 0
While x1 <= N
For i = x1 + 1 To N
If dt1(i).x = dt1(x1).x And dt1(i).y = dt1(x1).y Then
x2 = i
Else
Exit For
End If
Next i
If x2 - x1 > 0 Then
For k = x1 To x2
For j = x1 To x2 - k + x1 - 1
If dt1(j + 1).y < dt1(j).y Then
tmp = dt1(j + 1)
dt1(j + 1) = dt1(j)
dt1(j) = tmp
End If
Next j
Next k
End If
x1 = i
x2 = x1
Wend
End If
'----------返回
For i = 0 To N
dt(i) = dt1(i)
Next i
End Function
6楼的解法，好好要研究一下。
谢谢排序
谢谢高手的指点，非常有用，不过你好像误解了我的意思了，我不是准备给选择集内的对象按照坐标来排序，而是要让他排好序后这些图元还是在选择集内，只是需要排列选择集内图元的在选择集内的顺序。比如可以把sset.item(0)与sset.item(1)做比较，比较条件是其插入点的坐标从从上到下，从做到右，然后把sset.item(0)赋给sset.item(3),sset.item(0)赋为item(1)的值，在把SSET.ITEM(1)赋为item(3)的值。 本帖最后由 作者 于 2007-12-3 21:19:50 编辑以下的排序方法：
不重复排序+冒泡排序方法Sub als()Dim xm, xm1
Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity
aii = 0
ReDim xm(60) As Long, xm1(60) As Long
For Each Ent In ThisDrawing.ModelSpace
Select Case Ent.ObjectName
Case "AcDbLine"
Set ll = Ent
xm(aii) = ll.EndPoint(0)
xm1(aii) = ll.EndPoint(1)
aii = aii + 1
End Select
Next Ent
ReDim Preserve xm1(1000) As Long
bb = xx(xm1)
Dim abc() As Long
ReDim abc(UBound(bb)) As Long
For ii = 0 To UBound(bb)
abc(ii) = Val(bb(ii))
Next ii
cc = Bubble_Sort(abc)
For ii = 0 To UBound(cc)
Debug.Print ii, "-", cc(ii)
Next ii
ReDim Preserve xm(1000) As Long
bb = xx(xm)
ReDim abc(UBound(bb)) As Long
For ii = 0 To UBound(bb)
abc(ii) = Val(bb(ii))
Next ii
ccc = Bubble_Sort(abc)
For ii = 0 To UBound(ccc)
Debug.Print ii, "-", ccc(ii)
Next ii
ReDim xm(0), xm1(0)
End Sub
Function xx(xm)
Dim arr() As String, 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 '如果未找到
ReDim Preserve arr(0 To r)'定义动态数组大小
arr(r) = xm(i) '把姓名复制到数组Arr()中。
r = r + 1 '序号，自增1
End If
Next
xx = arr
End Function
Function Bubble_Sort(Ary)
Dim aryUBound, i, j
aryUBound = UBound(Ary)
For ii = 0 To aryUBound
Ary(ii) = Val(Round(Ary(ii), 2))
Next ii
For i = 0 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
本帖最后由 作者 于 2007-12-3 20:12:20 编辑 <br /><br /> <p>以上方法在处理AutoCAD的材料表处理中比较实用。</p>
页:
[1]
2