#2
patonzhai2020-09-11 11:13
|
只有本站会员才能查看附件,请 登录
Public Class Class4
Dim k, dmin As Integer
Dim x1, y1, x2, y2, d As Double
Dim arr As Object
Public Sub PCIcac()
dmin = InputBox("请输入核查距离(米)")
arr = app.ActiveSheet.Cells(1, 1).CurrentRegion.Value
k = 0
Dim brr(0 To 65536, 0 To 7)
For i = 2 To UBound(arr)
For j = 2 To UBound(arr)
If i <> j Then
x1 = Math.Round(arr(i, 3), 6)
y1 = Math.Round(arr(i, 4), 6)
x2 = Math.Round(arr(j, 3), 6)
y2 = Math.Round(arr(j, 4), 6)
d = CalcDistance(x1, y1, x2, y2)
If d <= dmin And arr(i, 5) = arr(j, 5) And arr(i, 6) = arr(j, 6) Then
brr(k, 1) = arr(i, 1)
brr(k, 3) = arr(j, 1)
brr(k, 2) = arr(i, 2)
brr(k, 4) = arr(j, 2)
brr(k, 5) = arr(i, 5)
brr(k, 6) = arr(i, 6)
brr(k, 7) = d
k += 1
End If
End If
Next j
Next i
app.ActiveSheet.Cells(2, 12).Resize(k - 1, 8) = brr
End Sub
Function CalcDistance(lon1 As Double, lat1 As Double, lon2 As Double, lat2 As Double) As Double
'经纬度计算距离公式,得出结果单位为米
Dim a_2d As Double = 6378137.0
Dim e_2d As Double = 0.00669438
Dim h_2d As Double = 15.0
Dim DEG_2_RAD As Double = 0.01745329252
Dim x_rads As Double = Math.Abs(lon1) * DEG_2_RAD
Dim y_rads As Double = Math.Abs(lat1) * DEG_2_RAD
Dim n_2ds As Double = a_2d / Math.Sqrt(1.0 - e_2d * Math.Sin(y_rads) * Math.Sin(y_rads))
Dim x_2d As Double = (n_2ds + h_2d) * Math.Cos(y_rads) * Math.Cos(x_rads)
Dim y_2d As Double = (n_2ds + h_2d) * Math.Cos(y_rads) * Math.Sin(x_rads)
Dim z_2d As Double = (n_2ds * (1.0 - e_2d) + h_2d) * Math.Sin(y_rads)
Dim x_radm As Double = Math.Abs(lon2) * DEG_2_RAD
Dim y_radm As Double = Math.Abs(lat2) * DEG_2_RAD
Dim n_2dm As Double = a_2d / Math.Sqrt(1.0 - e_2d * Math.Sin(y_radm) * Math.Sin(y_radm))
Dim x_2d_mark As Double = (n_2dm + h_2d) * Math.Cos(y_radm) * Math.Cos(x_radm)
Dim y_2d_mark As Double = (n_2dm + h_2d) * Math.Cos(y_radm) * Math.Sin(x_radm)
Dim z_2d_mark As Double = (n_2dm * (1.0 - e_2d) + h_2d) * Math.Sin(y_radm)
Dim curdistance As Double = (x_2d_mark - x_2d) * (x_2d_mark - x_2d) + (y_2d_mark - y_2d) * (y_2d_mark - y_2d) + (z_2d_mark - z_2d) * (z_2d_mark - z_2d)
Return Math.Sqrt(curdistance)
End Function
End Class