[VBA][VBA]请斑竹帮助调试

狐狸老兄

' 坐标点排序函数
' 语法：SortPoints(Points, SortMode)
' Points为坐标点数组
' SortMode为排序方式：0=X向，1=Y向，2=Z向
' 返回值为排序后的坐标点数组
Public function SortPoints(Points As Variant, SortMode As String) As Variant
Dim NewPoints() As Variant
ReDim NewPoints(UBound(Points))
Dim k As Long
For k = 0 To UBound(NewPoints)
NewPoints(k) = Points(k)
Next k

Dim BestPoint As Variant
Dim Pnt1 As Double
Dim Pnt2 As Double
Dim i As Long
Dim j As Long
Dim Best_Value As Double
Dim Best_j As Long
For i = 0 To UBound(NewPoints) - 1
Best_Value = NewPoints(i)(SortMode)
BestPoint = NewPoints(i)
Best_j = i
For j = i + 1 To UBound(NewPoints)
If NewPoints(j)(SortMode) < Best_Value Then
Best_Value = NewPoints(j)(SortMode)
BestPoint = NewPoints(j)
Best_j = j
End If
Next j
NewPoints(Best_j) = NewPoints(i)
NewPoints(i) = BestPoint
Next i
SortPoints = NewPoints
End Function ' 示例

Sub FindLineStartPoint()

Dim Sel As AcadSelectionSet

On Error Resume Next
Set Sel = ThisDrawing.SelectionSets.Add("ssel")
If Err Then
Err.Clear
ThisDrawing.SelectionSets("ssel").Delete
Set Sel = ThisDrawing.SelectionSets.Add("ssel")
End If
On Error GoTo 0

'选线
Sel.SelectOnScreen

'获取坐标点
Dim obj As AcadObject
Dim i As Integer
Dim pa(300) As Variant
Dim str As String
i = 0
str = "未排序坐标"
For Each obj In Sel
If obj.ObjectName = "AcDbLine" Then
pa(i) = obj.StartPoint
str = str & Chr(13) & " 第" & i + 1 & "点坐标为: ""( " & pa(i)(0) & "," & pa(i)(1) & _

"," & pa(i)(2) & ")" & Chr(13)
i = i + 1
End If
Next
MsgBox str

'排序
Dim pb As Variant
pb = SortPoints(pa, 0)

newtxt = 按X坐标点排序"
For i = 0 To UBound(pa)
newtxt = newtxt & vbCr & 第" & i + 1 & "点坐标为:" & pb(i)(0) & _
" " & pb(i)(1) & " " & pb(i)(2)
Next
MsgBox oldtxt & vbCr & vbCr & newtxt, , "明经通道VBA示例"
Sel.Delete
End Sub

[VBA]请斑竹帮助调试，屏幕选取直线获得起始点坐标数组，数组排序， If NewPoints(j)(SortMode) < Best_Value Then这一句有问题

subtlation

我把代码贴到vba编辑器中，红色的出错行很多啊。


楼主不是直接复制代码上来的？

subtlation

SortPoints函数没有问题，问题出在传递给函数的变量pa上，pa应该是一个点的数组，但你直接声明了pa(300)，但你选择的对象一般少于300，假定是N，那么pa的下标在N+1~300之间都没有定义，这样就不存在pa(j)(sortmode)。在主过程中把Dim pa(300)           As Variant改为Dim pa()           As Variant
k = Sel.Count
ReDim pa(k - 1)下面是我修改后的主过程，测试没有问题。

2. Sub FindLineStartPoint()Dim Sel   As AcadSelectionSetOn Error Resume Next
3. Set Sel = ThisDrawing.SelectionSets.Add("ssel")
4. If Err Then
5.    Err.Clear
6.    ThisDrawing.SelectionSets("ssel").Delete
7.    Set Sel = ThisDrawing.SelectionSets.Add("ssel")
8. End If
9. On Error GoTo 0  '选线
10. Sel.SelectOnScreen'获取坐标点
11. Dim obj                       As AcadObject
12. Dim i                               As Integer
13. Dim pa()           As Variant
14. k = Sel.Count
15. ReDim pa(k - 1)
16. Dim str                         As String
17. Dim k As Integer
18. i = 0
19. str = "未排序坐标"
20. For Each obj In Sel
21.    If obj.ObjectName = "AcDbLine" Then
22.          pa(i) = obj.StartPoint
23.          str = str & Chr(13) & " 第" & i + 1 & "点坐标为: ""( " & pa(i)(0) & "," & pa(i)(1) & _
24.          "," & pa(i)(2) & ")" & Chr(13)
25.            i = i + 1
26.          End If
27. Next
28. MsgBox str'排序
29. Dim pb As Variant
30. pb = SortPoints(pa, 0)newtxt = "按X坐标点排序"
31.        For i = 0 To UBound(pa)
32.                newtxt = newtxt & vbCr & "第" & i + 1 & "点坐标为:" & pb(i)(0) & _
33.                                "   " & pb(i)(1) & "     " & pb(i)(2)
34.        Next
35.        MsgBox oldtxt & vbCr & vbCr & newtxt, , "明经通道VBA示例"
36. Sel.Delete
37. End Sub

Sub FindLineStartPoint()Dim Sel   As AcadSelectionSetOn Error Resume Next Set Sel = ThisDrawing.SelectionSets.Add("ssel") If Err Then    Err.Clear    ThisDrawing.SelectionSets("ssel").Delete    Set Sel = ThisDrawing.SelectionSets.Add("ssel") End If On Error GoTo 0  '选线 Sel.SelectOnScreen'获取坐标点 Dim obj                       As AcadObject Dim i                               As Integer Dim pa()           As Variant k = Sel.Count ReDim pa(k - 1) Dim str                         As String Dim k As Integer i = 0 str = "未排序坐标" For Each obj In Sel    If obj.ObjectName = "AcDbLine" Then          pa(i) = obj.StartPoint          str = str & Chr(13) & " 第" & i + 1 & "点坐标为: ""( " & pa(i)(0) & "," & pa(i)(1) & _          "," & pa(i)(2) & ")" & Chr(13)            i = i + 1          End If Next MsgBox str'排序 Dim pb As Variant pb = SortPoints(pa, 0)newtxt = "按X坐标点排序"        For i = 0 To UBound(pa)                newtxt = newtxt & vbCr & "第" & i + 1 & "点坐标为:" & pb(i)(0) & _                                "   " & pb(i)(1) & "     " & pb(i)(2)        Next        MsgBox oldtxt & vbCr & vbCr & newtxt, , "明经通道VBA示例" Sel.Delete End Sub

   

狐狸老兄

谢谢 subtlation 我编程没几天，又很多基本问题还没没搞清楚。 －－－－－－－－－－－－ 学习、学习、再学习！