[VBA]两个数组的x值对比,如果不重复则插入到另一个数组中,请高手帮忙！
' 坐标点排序函数<BR>' 语法：SortPoints(Points, 0)<BR>' Points为坐标点数组<BR>' SortMode为排序方式：0=X向，1=Y向，2=Z向<BR>' 返回值为排序后的坐标点数组Public Function SortPoints(Points As Variant, SortMode As Variant) As Variant<BR> <BR> Dim NewPoints() As Variant<BR> ReDim NewPoints(UBound(Points))<BR> Dim k As Long<BR> For k = 0 To UBound(NewPoints)<BR> NewPoints(k) = Points(k)<BR> Next k<BR> <BR> Dim BestPoint As Variant<BR> Dim m As Variant<BR> Dim n As Variant<BR> Dim j As Variant<BR> <BR> Dim Best_Value As Double<BR> Dim Best_n As Variant<BR> <BR> For m = 0 To UBound(NewPoints) - 1<BR> Best_Value = NewPoints(m)(SortMode)<BR> BestPoint = NewPoints(m)<BR> Best_n = m<BR> <BR> For n = m + 1 To UBound(NewPoints)<BR> If NewPoints(n)(SortMode) < Best_Value Then<BR> Best_Value = NewPoints(n)(SortMode)<BR> BestPoint = NewPoints(n)<BR> Best_n = n<BR> End If<BR> <BR> Next n<BR> <BR> NewPoints(Best_n) = NewPoints(m)<BR> NewPoints(m) = BestPoint<BR> <BR> Next m<BR> <BR> SortPoints = NewPoints<BR> <BR>End Function ' 示例<BR>Sub FindLineStartPoint()<BR>Dim Sel As AcadSelectionSet
On Error Resume Next
Set Sel = ThisDrawing.SelectionSets.Add("ssel")
If Err Then<BR> Err.Clear<BR> ThisDrawing.SelectionSets("ssel").Delete<BR> Set Sel = ThisDrawing.SelectionSets.Add("ssel")<BR>End If<BR>On Error GoTo 0
'选取地表曲线
Sel.SelectOnScreen
'获取选取地表曲线起始点
Dim obj As AcadObject<BR>Dim i As Integer<BR>Dim Pa() As Variant<BR>Dim k As Integer<BR>k = Sel.Count<BR>ReDim Pa(k - 1)<BR>Dim str As String
i = 0<BR>str = "地表曲线未排序坐标"<BR>For Each obj In Sel<BR> If obj.ObjectName = "AcDbLine" Then<BR> Pa(i) = obj.StartPoint<BR> str = str & vbCr & " 第 " & i + 1 & " 点坐标为: " & Pa(i)(0) & " " & Pa(i)(1) & " " & Pa(i)(2)<BR> i = i + 1<BR> End If<BR>Next<BR> MsgBox str
<BR>'选取直线起始点排序
Pa = SortPoints(Pa, 0)
NewTxt = "按X坐标点大小排序"
For i = 0 To UBound(Pa)<BR> <BR> NewTxt = NewTxt & vbCr & "第" & i + 1 & "点坐标为:" & Pa(i)(0) & " " & Pa(i)(1) & " " & Pa(i)(2)<BR> Next
MsgBox NewTxt
Sel.Delete
'选取埋地管线<BR>Dim Selb As AcadSelectionSet<BR>Dim objb As AcadObject<BR>Set Selb = ThisDrawing.SelectionSets.Add("ssel")
Selb.SelectOnScreen
'获取选取埋地管线起始点
Dim Pb() As Variant<BR>k = Selb.Count<BR>ReDim Pb(k - 1)<BR>i = 0<BR>str = "埋地管线未排序坐标 "
For Each objb In Selb<BR> If objb.ObjectName = "AcDbLine" Then<BR> Pb(i) = objb.StartPoint<BR> str = str & vbCr & " 第 " & i + 1 & " 点坐标为: " & Pb(i)(0) & " " & Pb(i)(1) & " " & Pb(i)(2)<BR> i = i + 1<BR> End If<BR>Next<BR> MsgBox str
Pb = SortPoints(Pb, 0)
NewTxt = "埋地管线按X坐标点大小排序"
For i = 0 To UBound(Pb)<BR> <BR> NewTxt = NewTxt & vbCr & "第" & i + 1 & "点坐标为:" & Pb(i)(0) & " " & Pb(i)(1) & " " & Pb(i)(2)<BR> <BR> Next
MsgBox NewTxt<BR> <BR> <BR> '地面曲线和麦地管线坐标数组排序
Dim m As Long<BR>Dim j As Long<BR>Dim e As Long<BR>Dim X1 As Double<BR>Dim X2 As Double<BR>Dim Y1 As Double<BR>Dim Y2 As Double<BR>Dim Xk As Double<BR>Dim Yk As Double<BR>Dim Pc As Variant
Pc = SortPoints(Pa, 0)
For m = 0 To UBound(Pb)
k = UBound(Pc)<BR> <BR> j = 0<BR> <BR> For i = 0 To k
If Pc(i)(0) <> Pb(m)(0) Then j = j + 1<BR> <BR> Next<BR> <BR> ReDim Preserve Pc(k + 1)<BR> <BR> If j = k Then Pc(k + 1) = Pb(m)<BR> <BR> For e = 0 To UBound(Pc)<BR> <BR> X1 = Pc(e)(0)<BR> X2 = Pc(e + 1)(0)<BR> Y1 = Pc(e)(1)<BR> Y2 = Pc(e + 1)(1)<BR> Xk = Pc(k)(0)<BR> Yk = Pc(k)(1)<BR> <BR> <BR> If Pc(e)(0) < Pc(k)(0) < Pc(e + 1)(0) Then Pc(k)(1) = (Xk - X1) / (X2 - X1) * Sqr((Y2 - Y1) ^ 2 + (X2 - X1) ^ 2): Pc(k)(2) = 0<BR> <BR> Next<BR> <BR>Pc = SortPoints(Pc, 0)
Next<BR>'Selb.Delete<BR>End Sub For m = 0 To UBound(NewPoints) - 1<BR> For n = m + 1 To UBound(NewPoints)<BR> If NewPoints(n)(SortMode) < NewPoints(m)(SortMode) Then<BR> BestPoint=NewPoints(n)<BR> NewPoints(n)=NewPoints(m)<BR> NewPoints(m) = n<BR> End If<BR> Next n<BR> Next m
页:
[1]