[讨论]vba,请大家给个源码，根据一系列点的X坐标大小排序

bzjustb

给大家拜年啦！

yfy2003

看看这个帖子，一定对你有所帮助！ http://bbs.mjtd.com/forum.php?mod=viewthread&tid=15190

mccad

2. ' 坐标点排序函数
3. ' 语法：SortPoints(Points, SortMode)
4. ' Points为坐标点数组
5. ' SortMode为排序方式：0=X向，1=Y向，2=Z向
6. ' 返回值为排序后的坐标点数组
7. Public Function SortPoints(Points As Variant, SortMode As String) As Variant
8.        Dim NewPoints() As Variant
9.        ReDim NewPoints(UBound(Points))
10.        Dim k As Long
11.        For k = 0 To UBound(NewPoints)
12.                NewPoints(k) = Points(k)
13.        Next k
14.       
15.        Dim BestPoint As Variant
16.        Dim Pnt1 As Double
17.        Dim Pnt2 As Double
18.        Dim i As Long
19.        Dim j As Long
20.        Dim Best_Value As Double
21.        Dim Best_j As Long
22.        For i = 0 To UBound(NewPoints) - 1
23.                Best_Value = NewPoints(i)(SortMode)
24.                BestPoint = NewPoints(i)
25.                Best_j = i
26.                For j = i + 1 To UBound(NewPoints)
27.                        If NewPoints(j)(SortMode) < Best_Value Then
28.                                Best_Value = NewPoints(j)(SortMode)
29.                                BestPoint = NewPoints(j)
30.                                Best_j = j
31.                        End If
32.                Next j
33.                NewPoints(Best_j) = NewPoints(i)
34.                NewPoints(i) = BestPoint
35.        Next i
36.        SortPoints = NewPoints
37. End Function' 示例
38. Sub SortPointsSample()
39.        Dim Pnts(5) As Variant
40.        Dim i As Integer
41.        Dim OldTxt As String
42.        Dim NewTxt As String
43.        OldTxt = "未排序坐标："
44.        ThisDrawing.Utility.Prompt vbCr & "请按顺序随意点取6个坐标点" & vbCrLf
45.        For i = 0 To 5
46.                Pnts(i) = ThisDrawing.Utility.GetPoint(, vbCr & "点取第" & i + 1 & "点坐标点:")
47.                OldTxt = OldTxt & vbCr & "第" & i + 1 & "点坐标为：" & Pnts(i)(0) & _
48.                                "   " & Pnts(i)(1) & "     " & Pnts(i)(2)
49.        Next
50.        Dim NewPnts As Variant
51.        NewPnts = SortPoints(Pnts, 0)
52.        NewTxt = "按X坐标排序的顺序："
53.        For i = 0 To 5
54.                NewTxt = NewTxt & vbCr & "第" & i + 1 & "点坐标为：" & NewPnts(i)(0) & _
55.                                "   " & NewPnts(i)(1) & "     " & NewPnts(i)(2)
56.        Next
57.        MsgBox OldTxt & vbCr & vbCr & NewTxt, , "明经通道VBA示例"
58. End Sub

' 坐标点排序函数 ' 语法：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 SortPointsSample()        Dim Pnts(5) As Variant        Dim i As Integer        Dim OldTxt As String        Dim NewTxt As String        OldTxt = "未排序坐标："        ThisDrawing.Utility.Prompt vbCr & "请按顺序随意点取6个坐标点" & vbCrLf        For i = 0 To 5                Pnts(i) = ThisDrawing.Utility.GetPoint(, vbCr & "点取第" & i + 1 & "点坐标点:")                OldTxt = OldTxt & vbCr & "第" & i + 1 & "点坐标为：" & Pnts(i)(0) & _                                "   " & Pnts(i)(1) & "     " & Pnts(i)(2)        Next        Dim NewPnts As Variant        NewPnts = SortPoints(Pnts, 0)        NewTxt = "按X坐标排序的顺序："        For i = 0 To 5                NewTxt = NewTxt & vbCr & "第" & i + 1 & "点坐标为：" & NewPnts(i)(0) & _                                "   " & NewPnts(i)(1) & "     " & NewPnts(i)(2)        Next        MsgBox OldTxt & vbCr & vbCr & NewTxt, , "明经通道VBA示例" End Sub

subtlation

我自己写过一个对点进行排序的函数，可以同时对xy坐标进行排序。

2. Public Sub PtList(points, ByVal HAlign As Boolean, ByVal VAlign As Boolean, _
3.                                                                                                          priority As Integer)
4.    '对点集points 进行排序
5.    'priority = 0 表示先排X坐标，priority = 1 表示先排Y坐标
6.    'HAlign = True 表示X坐标从小到大，HAlign = False 表示X坐标从大到小
7.    'VAlign = True 表示Y坐标从小到大，VAlign = False 表示Y坐标从大到小
8.    
9.    Dim pt1, pt2 As Variant
10.    Dim n As Integer
11.    Dim A, B As Boolean
12.    n = priority
13.    If n = 0 Then
14.        A = HAlign
15.        B = VAlign
16.    ElseIf n = 1 Then
17.        A = VAlign
18.        B = HAlign
19.    End If
20.    '主方向排序
21.    For i = LBound(points) To UBound(points)
22.        For j = i To UBound(points)
23.            pt1 = points(i)
24.            pt2 = points(j)
25.            If pt1(n) > pt2(n) Eqv A Then
26.                points(i) = pt2
27.                points(j) = pt1
28.            End If
29.        Next j
30.    Next i
31.    '副方向排序
32.    For i = LBound(points) To UBound(points)
33.        For j = i To UBound(points)
34.            pt1 = points(i)
35.            pt2 = points(j)
36.          If pt1(n) = pt2(n) Then
37.            If pt1(1 - n) > pt2(1 - n) Eqv B Then
38.                points(i) = pt2
39.                points(j) = pt1
40.            End If
41.          End If
42.        Next j
43.    Next i
44.    
45. End Sub

Public Sub PtList(points, ByVal HAlign As Boolean, ByVal VAlign As Boolean, _                                                                                                          priority As Integer)    '对点集points 进行排序    'priority = 0 表示先排X坐标，priority = 1 表示先排Y坐标    'HAlign = True 表示X坐标从小到大，HAlign = False 表示X坐标从大到小    'VAlign = True 表示Y坐标从小到大，VAlign = False 表示Y坐标从大到小        Dim pt1, pt2 As Variant    Dim n As Integer    Dim A, B As Boolean    n = priority    If n = 0 Then        A = HAlign        B = VAlign    ElseIf n = 1 Then        A = VAlign        B = HAlign    End If    '主方向排序    For i = LBound(points) To UBound(points)        For j = i To UBound(points)            pt1 = points(i)            pt2 = points(j)            If pt1(n) > pt2(n) Eqv A Then                points(i) = pt2                points(j) = pt1            End If        Next j    Next i    '副方向排序    For i = LBound(points) To UBound(points)        For j = i To UBound(points)            pt1 = points(i)            pt2 = points(j)          If pt1(n) = pt2(n) Then            If pt1(1 - n) > pt2(1 - n) Eqv B Then                points(i) = pt2                points(j) = pt1            End If          End If        Next j    Next i     End Sub