选择集内多段线排序问题

tataki · 发表于 2016-1-5 10:45:00

大家好，我的一张图纸里有5个封闭的多段线图形，我要将他们在选择集内按照面积从大到小的顺序提取出来，可是我用下面的代码为什么没有结果呢，明明符合冒泡的交换原则，但是选择集里面的顺序没有改变。
在开始排序前，对sset中 item（0），item（1）...的面积进行显示，分别是
70649.8308504972
568562.9282529
41212.9767410917
122193.519887502
2910000
在排序后，再从item（0）开始显示面积，结果仍然和前面的一样，请大家指导一下究竟是哪里不对？
附上程序代码和图纸。谢谢！Sub PartSequence()
Dim ftype(0 To 1) As Integer
Dim fdata(0 To 1) As Variant
ftype(0) = 0: fdata(0) = "LWPolyline" '定义过滤器筛选类别，筛选多段线
ftype(1) = 8: fdata(1) = "parts" '定义过滤器筛选图层，筛选 parts图层

  On Error Resume Next
  Dim SSet As AcadSelectionSet
   If Not IsNull(ThisDrawing.SelectionSets.Item("SSetParts")) Then
      Set SSet = ThisDrawing.SelectionSets.Item("SSetParts")
      SSet.Delete
End If
Set SSet = ThisDrawing.SelectionSets.Add("SSetParts")
SSet.Select acSelectionSetAll, , , ftype, fdata

'从item0开始逐个显示排序前的面积
Dim ipart As AcadLWPolyline
For i = 0 To SSet.Count - 1
   Set ipart = SSet.Item(i)
   Debug.Print ipart.Area
Next

'要对sset里面的数据按照面积从大到小的顺序排序

Dim iOuter As Long
Dim iInner As Long
Dim iLBound As Long
Dim iUBound As Long
Dim iTemp As IAcadLWPolyline
Dim iTempA As IAcadLWPolyline
Dim iTempB As IAcadLWPolyline
iLBound = 0
iUBound = SSet.Count
   Debug.Print SSet.Item(0).ObjectID; SSet.Item(1).ObjectID; SSet.Item(2).ObjectID
'冒泡排序从大到小
For jj = 0 To SSet.Count - 2
      For ii = 0 To SSet.Count - 1 - jj
         Set iTempA = SSet.Item(ii)
         Set iTempB = SSet.Item(ii + 1)
         '比较相邻项
         If (iTempA.Area

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

万里天 · 发表于 2016-10-25 19:20:00

给你个解决办法:
Sub 多段线按面积按大小输出()
Dim SSet As AcadSelectionSet
Dim ftype(0 To 1) As Integer
Dim fdata(0 To 1) As Variant
ftype(0) = 0: fdata(0) = "LWPolyline" '定义过滤器筛选类别，筛选多段线
ftype(1) = 8: fdata(1) = "*" '定义过滤器筛选图层，筛选 parts图层
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item("SSetParts")) Then Set SSet = ThisDrawing.SelectionSets.Item("SSetParts"): SSet.Delete
On Error GoTo 0
Set SSet = ThisDrawing.SelectionSets.Add("SSetParts")
SSet.Select acSelectionSetAll, , , ftype, fdata
'选择集转换为对象数组:返回包含于选择集中每一项目的变体数组
Dim i As Long
Dim retVal() As AcadEntity
ReDim retVal(0 To SSet.Count - 1)
For i = 0 To SSet.Count - 1
      Set retVal(i) = SSet.Item(i)
      Debug.Print SSet.Item(i).area '逐个显示排序前的面积
Next

'冒泡排序:按照面积从小到大的顺序
Dim iOuter As Long
Dim iInner As Long
Dim iLBound As Long
Dim iUBound As Long
Dim iTemp As AcadEntity
iLBound = LBound(retVal): iUBound = UBound(retVal)
'冒泡排序
For iOuter = iLBound To iUBound - 1
      For iInner = iLBound To iUBound - iOuter - 1
         If retVal(iInner).area > retVal(iInner + 1).area Then '比较相邻项
            Set iTemp = retVal(iInner)
            Set retVal(iInner) = retVal(iInner + 1) '交换
            Set retVal(iInner + 1) = iTemp
         End If
      Next iInner
Next iOuter
Debug.Print "面积从小到大排序结果: "
Dim ipart2 As AcadEntity
For i = 0 To UBound(retVal)
      Set ipart2 = retVal(i)
      Debug.Print ipart2.area
Next
End Sub

万里天 · 发表于 2016-10-25 19:22:00

根本没那么玄乎.

mikewolf2k · 发表于 2016-1-5 11:10:00

建议楼主将 On Error Resume Next去掉，然后一步步的调试，每次交换完毕看看是否交换成功。这种问题很容易自己解决的。

tataki · 发表于 2016-1-5 11:55:00

这么快就回复了，非常感谢！
我去掉 on error后，再这一行出现了错误
SSet.Item(ii + 1) = SSet.Item(ii)
也就是交换选择集内的顺序时不对，错误提示为对象不支持该属性或方法
这一点不太理解，如果是数组的话，这样使用没有任何问题，
可是到了选择集，为什么这样用就错了呢？