📄 frmdist.frm
字号:
VERSION 5.00
Begin VB.Form frmDist
Caption = "大地线长度"
ClientHeight = 3120
ClientLeft = 60
ClientTop = 450
ClientWidth = 4155
LinkTopic = "Form1"
ScaleHeight = 3120
ScaleWidth = 4155
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox txtDist
Height = 375
Left = 1920
TabIndex = 5
Top = 1560
Width = 1935
End
Begin VB.CommandButton cmdCal
Caption = "计算"
Height = 375
Left = 120
TabIndex = 4
Top = 1560
Width = 1215
End
Begin VB.TextBox txtB
Height = 375
Index = 1
Left = 2640
TabIndex = 3
Top = 960
Width = 1215
End
Begin VB.TextBox txtB
Height = 375
Index = 0
Left = 2640
TabIndex = 2
Top = 360
Width = 1215
End
Begin VB.TextBox txtL
Height = 375
Index = 1
Left = 480
TabIndex = 1
Top = 960
Width = 1215
End
Begin VB.TextBox txtL
Height = 375
Index = 0
Left = 480
TabIndex = 0
Top = 360
Width = 1215
End
Begin VB.Label Label7
Caption = "有任何问题请联系：http://www.sciencenet.cn/blog/zjwang.htm"
Height = 375
Left = 120
TabIndex = 12
Top = 2520
Width = 3855
End
Begin VB.Label Label6
Caption = "说明：程序中角度一率采用度、分、秒六二进制表示。"
Height = 495
Left = 120
TabIndex = 11
Top = 2040
Width = 3855
End
Begin VB.Label Label5
Caption = "S"
Height = 375
Left = 1560
TabIndex = 10
Top = 1680
Width = 255
End
Begin VB.Label Label4
Caption = "B1"
Height = 255
Left = 2280
TabIndex = 9
Top = 480
Width = 255
End
Begin VB.Label Label3
Caption = "B2"
Height = 255
Left = 2280
TabIndex = 8
Top = 960
Width = 255
End
Begin VB.Label Label2
Caption = "L2"
Height = 255
Left = 120
TabIndex = 7
Top = 960
Width = 255
End
Begin VB.Label Label1
Caption = "L1"
Height = 255
Left = 120
TabIndex = 6
Top = 480
Width = 255
End
End
Attribute VB_Name = "frmDist"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdCal_Click()
txtDist = GetDistance(Val(txtL(0)), Val(txtB(0)), Val(txtL(1)), Val(txtB(1)))
End Sub
'*******************************************************************************
'
' 函数名：GetDistance
' 描 述：根据地球表面两点经纬度获得两点之间大地线长度
' 信 息：汪自军 吉林大学 2006.3
' 参 数：
' Double dL1 第一个点的经度
' Double dB1 第一个点的纬度
' Double dL1 第一个点的经度
' Double dB1 第一个点的纬度
' 返回值：两点大地线长度
'
'*********************************************************************************
Function DecTranToRad(ByVal dSextileAngle As Double) As Double
DecTranToRad = dSextileAngle * 3.14159265358974 / 180
End Function
Public Function ArcCos(x As Double) As Double
ArcCos = Atn(-x / Sqr((-x * x + 1) + 0.000000000001)) + 2 * Atn(1)
End Function
Function ArcSin(x As Double) As Double
ArcSin = Atn(x / Sqr(-x * x + 1))
End Function
Function GetDistance(ByVal dL1 As Double, ByVal dB1 As Double, ByVal dL2 As Double, ByVal dB2 As Double) As Double
dL1 = DecTranToRad(dL1) '六十进制角度转化为弧度制 当经度相同时不可用此程序
dB1 = DecTranToRad(dB1)
dL2 = DecTranToRad(dL2)
dB2 = DecTranToRad(dB2)
Dim u1 As Double
Dim u2 As Double
Dim l As Double
Dim e
e = 0.006693421622966
Dim W1
W1 = Sqr(1 - e * Sin(dB1) * Sin(dB1))
Dim W2
W2 = Sqr(1 - e * Sin(dB2) * Sin(dB2))
Dim f1 As Double
f1 = Cos(dB1) / W1: u1 = ArcCos(f1)
Dim f2 As Double
f2 = Cos(dB2) / W2: u2 = ArcCos(f2)
l = dL2 - dL1
Dim a1
a1 = Sin(u1) * Sin(u2)
Dim a2
a2 = Cos(u1) * Cos(u2)
Dim b1
b1 = Cos(u1) * Sin(u2)
Dim b2
b2 = Sin(u1) * Cos(u2)
Dim x
Dim k
k = l + x
Dim y
Dim p
Dim q
Dim A3
Dim s
If dL1 = dL2 And dB1 <> dB2 Then
s = Abs(111134.861 * dB1 * 180 / 3.141592654 - 32005.78 * Sin(dB1) * Cos(dB1) - 133.929 * Sin(dB1) * Sin(dB1) * Sin(dB1) * Cos(dB1) - 0.697 * Sin(dB1) * Sin(dB1) * Sin(dB1) * Sin(dB1) * Sin(dB1) * Cos(dB1) - 111134.861 * dB2 * 180 / 3.141592654 + 32005.78 * Sin(dB2) * Cos(dB2) + 133.929 * Sin(dB2) * Sin(dB2) * Sin(dB2) * Cos(dB2) + 0.697 * Sin(dB2) * Sin(dB2) * Sin(dB2) * Sin(dB2) * Sin(dB2) * Cos(dB2))
ElseIf dB1 = dB2 And dL1 <> dL2 Then
s = 6378245 * Cos(dB1) * Abs(dL1 - dL2) / Sqr(1 - e * Sin(dB1) * Sin(dB1))
ElseIf dL1 = dL2 And dB1 = dB2 Then
s = 0
Else
x = 0
p = Cos(u2) * Sin(k)
q = b1 - b2 * Cos(k)
A3 = Atn(p / q)
If p >= 0 And q > 0 Then
A3 = Abs(A3)
ElseIf p >= 0 And q < 0 Then
A3 = 3.141592654 - Abs(A3)
ElseIf p < 0 And q < 0 Then
A3 = 3.141592654 + Abs(A3)
Else
A3 = 2 * 3.141592654 - Abs(A3)
End If
Dim L1: L1 = p * Sin(A3) + q * Cos(A3)
Dim L2: L2 = a1 + a2 * Cos(k)
Dim g: g = Atn(L1 / L2)
If Cos(g) >= 0 Then
g = Abs(g)
Else
g = 3.1415926 - Abs(g)
End If
Dim A0
Dim f3 As Double: f3 = Cos(u1) * Sin(A3): A0 = ArcSin(f3)
Dim m: m = 2 * a1 - Cos(A0) * Cos(A0) * Cos(g)
Dim a: a = (33523299 - (28189 - 70 * Cos(A0) * Cos(A0)) * Cos(A0) * Cos(A0)) * 0.0000000001
Dim b: b = (28189 - 94 * Cos(A0) * Cos(A0)) * 0.0000000001
y = (a * g - b * m * Sin(g)) * Sin(A0)
While Abs(x - y) > 10 ^ -8
x = y
k = l + x
p = Cos(u2) * Sin(k)
q = b1 - b2 * Cos(k)
A3 = Atn(p / q)
If p >= 0 And q >= 0 Then
A3 = Abs(A3)
ElseIf p >= 0 And q <= 0 Then
A3 = 3.1415926 - Abs(A3)
ElseIf p < 0 And q < 0 Then
A3 = 3.1415926 + Abs(A3)
Else
A3 = 2 * 3.1415926 - Abs(A3)
End If
L1 = p * Sin(A3) + q * Cos(A3)
L2 = a1 + a2 * Cos(k)
g = Atn(L1 / L2)
If Cos(g) >= 0 Then
g = Abs(g)
Else
g = 3.1415926 - Abs(g)
End If
f3 = Cos(u1) * Sin(A3): A0 = ArcSin(f3)
m = 2 * a1 - Cos(A0) * Cos(A0) * Cos(g)
a = (33523299 - (28189 - 70 * Cos(A0) * Cos(A0)) * Cos(A0) * Cos(A0)) * 0.0000000001
b = (28189 - 94 * Cos(A0) * Cos(A0)) * 0.0000000001
y = (a * g - b * m * Sin(g)) * Sin(A0)
Wend
x = y
Dim T: T = 6356863.02 + (10708.949 - 13.474 * Cos(A0) * Cos(A0)) * Cos(A0) * Cos(A0)
Dim H: H = 10708.938 - 17.956 * Cos(A0) * Cos(A0)
Dim C: C = 4.487
Dim X2: X2 = (Cos(A0) * Cos(A0) * Cos(A0) * Cos(A0) - 2 * m * m) * Cos(g)
s = T * g + (H * m + C * X2) * Sin(g)
End If
GetDistance = s
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -