选择集内多段线排序问题

vbcad

我想这个应该不涉及CAD的数据库，选择集里元素是对象，
SSet.Item(ii + 1) = SSet.Item(ii)为什么错误，因为对象不能直接用等于。
既然是对象，就应该加上SET
所以
               SSet.Item(ii + 1) = SSet.Item(ii)
                SSet.Item(ii) = iTemp
都应该加SET

tataki

vbcad 发表于 2016-1-7 22:05
我想这个应该不涉及CAD的数据库，选择集里元素是对象，
SSet.Item(ii + 1) = SSet.Item(ii)为什么错误，因 ...

你说的加上 set ，我前天也试过了，然后这个错误就没有了，但是...我单步运行的时候，在交换语句那里没有错误，问题是执行过交换后，这个sset里面item的顺序并没有互换，也就是说即使程序执行了交换动作，也是无效的。。。这个我就非常奇怪。
我用debug命令都显示了交换前后的面积，结果仍然是一样的，见图片里红框的地方。我也不清楚为什么会这样~~

雪山飞狐_lzh

选择集的顺序在选择后是不可变的 因为底层的对象还包含选择方式,选择点等参数
Vba的选择集只是个封装

tataki

雪山飞狐_lzh 发表于 2016-1-7 22:42
选择集的顺序在选择后是不可变的 因为底层的对象还包含选择方式,选择点等参数
Vba的选择集只是个封装

感谢飞狐版主热心解释。
我觉得这种问题非常隐蔽和晦涩，程序一路运行下去一点错都不报，但是就是没有效果，如果不了解到底层对象这些概念，发现不了问题。
另外，飞狐版主对于选择集顺序等不可改变这些信息是从哪里来获取？对这些没有概念啊。

雪山飞狐_lzh

Objectarx和.netapi的选择集的组成都是这样
选择集是selectedobject对象的集合
而该对象包含objectid  pickpoint  selectmode等
Vba的选择集应该是在objectarx选择集基础的封装

万里天

给你个解决办法:
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

万里天

根本没那么玄乎.