📄 大地正反算.frm
字号:
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 0
TabIndex = 6
Top = 0
Width = 1215
End
End
Begin VB.Frame Frame1
Height = 855
Left = 5760
TabIndex = 2
Top = 1440
Width = 2055
Begin VB.OptionButton Option2
Caption = "反算"
Height = 255
Left = 1080
TabIndex = 4
Top = 360
Width = 855
End
Begin VB.OptionButton Option1
Caption = "正算"
Height = 300
Left = 120
TabIndex = 3
Top = 360
Value = -1 'True
Width = 1095
End
End
Begin VB.ComboBox Combo1
Height = 300
ItemData = "大地正~1.frx":0000
Left = 2160
List = "大地正~1.frx":0010
Style = 2 'Dropdown List
TabIndex = 0
Top = 1560
Width = 2295
End
Begin VB.Label Label13
Caption = "大地线长度S"
BeginProperty Font
Name = "宋体"
Size = 15.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 1560
TabIndex = 14
Top = 5040
Width = 1935
End
Begin VB.Label Label4
Caption = "大地主题正反算"
BeginProperty Font
Name = "宋体"
Size = 15.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3360
TabIndex = 11
Top = 480
Width = 2295
End
Begin VB.Label Label1
Caption = "选择椭球"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 1200
TabIndex = 1
Top = 1560
Width = 855
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Form_Load()
Text3(0).Text = "40,00,08.3421"
Text3(1).Text = "115,46,27.0953"
Text3(4).Text = "75,41,29.762"
TextS.Text = "24909.814"
End Sub
Private Sub Combo1_Click()
Text1.Enabled = False
Text2.Enabled = False
Select Case Combo1.ListIndex
Case 0
Text1.Text = Str(6378245)
Text2.Text = Str(1 / 298.3)
Case 1
Text1.Text = Str(6378137)
Text2.Text = Str(1 / 198.257)
Case 2
Text1.Text = Str(6378140)
Text2.Text = Str(1 / 298.257)
Case 3
Text1.Enabled = True
Text2.Enabled = True
MsgBox "请输入椭球参数"
Text1.Text = ""
Text2.Text = ""
End Select
End Sub
Private Sub Zheng()
Dim a1 As Double, E1 As Double, q As Double, B1 As Double, L1 As Double, B2 As Double, L2 As Double, A12 As Double, A21 As Double
Dim s1() As String, s2() As Double, s0 As Double, z(1) As Double, Am As Double, Bm As Double, S As Double
Dim Am0 As Double, Bm0 As Double, M1 As Double, N1 As Double, Mm As Double, Nm As Double
Dim a0 As Double, b0 As Double, l0 As Double, a As Double, b As Double, l As Double
Dim a01 As Double, b01 As Double, l01 As Double, a10 As Double, b10 As Double, l10 As Double
If Text1.Text = "" Or Text2.Text = "" Or Text3(4).Text = "" Or Text3(0).Text = "" Or Text3(0).Text = "" Then
MsgBox "起算数据不全"
Exit Sub
End If
For j = 0 To 1
s0 = 0
s1 = Split(Text3(j), ",")
ReDim s2(UBound(s1))
For i = LBound(s1) To UBound(s1)
s2(i) = Val(s1(i))
s0 = s0 + s2(i) * 3.1415926 / 180 / 60 ^ i
Next i
z(j) = s0
Next j
B1 = z(0)
L1 = z(1)
a1 = Val(Text1.Text)
q = Val(Text2.Text)
E1 = Sqr(2 * q - q ^ 2)
s0 = 0
s1 = Split(Text3(4), ",")
ReDim s2(UBound(s1))
For i = LBound(s1) To UBound(s1)
s2(i) = Val(s1(i))
s0 = s0 + s2(i) * 3.1415926 / 180 / 60 ^ i
Next i
A12 = s0
M1 = a1 * (1 - E1) / (Sqr(1 - E1 * (Sin(B1)) ^ 2)) ^ 3
N1 = a1 * (1 - E1) / Sqr(1 - E1 * (Sin(B1)) ^ 2)
S = Val(TextS.Text)
Bm0 = B1 + ((S * Cos(A12)) / (2 * M1))
Am0 = A12 + ((Sin(B1) * S * Sin(A12)) / (2 * N1 * Cos(B1)))
Mm = a1 * (1 - E1) / (Sqr(1 - E1 * (Sin(Bm0)) ^ 2)) ^ 3
Nm = a1 * (1 - E1) / Sqr(1 - E1 * (Sin(Bm0)) ^ 2)
b0 = (S * Cos(Am0)) / Mm
l0 = (S * Sin(Am0)) / (Nm * Cos(Bm0))
a0 = l0 * Sin(Bm0)
l = l0 * (1 + a0 ^ 2 / 24 - b0 ^ 2 / 24)
b = b0 * (1 + (l0 ^ 2 * (Cos(Bm0) ^ 2)) / 12 + a0 ^ 2 / 8)
a = a0 * (1 + b0 ^ 2 / 12 + (l0 * (1 + (Cos(Bm0)) ^ 2)) / 24)
Bm = B1 + b
Am = A12 + a
Mm = a1 * (1 - E1) / (Sqr(1 - E1 * (Sin(Bm)) ^ 2)) ^ 3
Nm = a1 * (1 - E1) / Sqr(1 - E1 * (Sin(Bm)) ^ 2)
b0 = (S * Cos(Am)) / Mm
l0 = (S * Sin(Am)) / (Nm * Cos(Bm))
a0 = l0 * Sin(Bm)
l10 = l0 * (1 + a0 ^ 2 / 24 - b0 ^ 2 / 24)
b10 = b0 * (1 + (l0 ^ 2 * (Cos(Bm0) ^ 2)) / 12 + a0 ^ 2 / 8)
a10 = a0 * (1 + b0 ^ 2 / 12 + (l0 * (1 + (Cos(Bm0)) ^ 2)) / 24)
Do While Abs(l10 - l) > 0.0001 / 206265 Or Abs(b10 - b) > 0.0001 / 206265 Or Abs(a10 - a) > 0.001 / 206265
a = a10
b = b10
l = l10
Bm = B1 + b
Am = A12 + a
Mm = a1 * (1 - E1) / (Sqr(1 - E1 * (Sin(Bm)) ^ 2)) ^ 3
Nm = a1 * (1 - E1) / Sqr(1 - E1 * (Sin(Bm)) ^ 2)
b0 = (S * Cos(Am)) / Mm
l0 = (S * Sin(Am)) / (Nm * Cos(Bm))
a0 = l0 * Sin(Bm)
l10 = l0 * (1 + a0 ^ 2 / 24 - b0 ^ 2 / 24)
b10 = b0 * (1 + (l0 ^ 2 * (Cos(Bm0) ^ 2)) / 12 + a0 ^ 2 / 8)
a10 = a0 * (1 + b0 ^ 2 / 12 + (l0 * (1 + (Cos(Bm0)) ^ 2)) / 24)
Loop
B2 = B1 + b10
L2 = L1 + l10
A21 = A12 + (a / 2) + 3.1415926
If A21 > 6.2831852 Then
A21 = A21 - 6.2831852
End If
Text3(2).Text = Fix(B2 * 180 / 3.1415926) & "," & Fix(((B2 * 180 / 3.1415926) - Fix(B2 * 180 / 3.1415926)) * 60) & "," & ((((B2 * 180 / 3.1415926) - Fix(B2 * 180 / 3.1415926)) * 60) - Fix(((B2 * 180 / 3.1415926) - Fix(B2 * 180 / 3.1415926)) * 60)) * 60
Text3(3).Text = Fix(L2 * 180 / 3.1415926) & "," & Fix(((L2 * 180 / 3.1415926) - Fix(L2 * 180 / 3.1415926)) * 60) & "," & ((((L2 * 180 / 3.1415926) - Fix(L2 * 180 / 3.1415926)) * 60) - Fix(((L2 * 180 / 3.1415926) - Fix(L2 * 180 / 3.1415926)) * 60)) * 60
Text3(5).Text = Fix(A21 * 180 / 3.1415926) & "," & Fix(((A21 * 180 / 3.1415926) - Fix(A21 * 180 / 3.1415926)) * 60) & "," & ((((A21 * 180 / 3.1415926) - Fix(A21 * 180 / 3.1415926)) * 60) - Fix(((A21 * 180 / 3.1415926) - Fix(A21 * 180 / 3.1415926)) * 60)) * 60
End Sub
Private Sub Command1_Click()
Dim Js As Boolean
Js = IIf(Option1, True, False)
If Js = True Then
Call Zheng
End If
If Js = False Then
Call Fan
End If
End Sub
Private Sub Fan()
Dim a1 As Double, E1 As Double, E2 As Double, q As Double, B1 As Double, L1 As Double, B2 As Double, L2 As Double, A12 As Double, A21 As Double
Dim s1() As String, s2() As Double, s0 As Double, z(3) As Double, Am As Double, Bm As Double, S As Double
Dim Am0 As Double, Bm0 As Double, Mm As Double, Nm As Double, D1 As Double, D2 As Double
Dim a As Double, b As Double, l As Double
Dim t As Double, Y As Double, Vm As Double
If Text3(0).Text = "" Or Text3(1).Text = "" Or Text3(2).Text = "" Or Text3(3).Text = "" Or Text1.Text = "" Or Text2.Text = "" Then
MsgBox "起算数据不全"
Exit Sub
End If
For j = 0 To 3
s0 = 0
s1 = Split(Text3(j), ",")
ReDim s2(UBound(s1))
For i = LBound(s1) To UBound(s1)
s2(i) = Val(s1(i))
s0 = s0 + s2(i) * 3.1415926 / 180 / 60 ^ i
Next i
z(j) = s0
Next j
B1 = z(0)
L1 = z(1)
B2 = z(2)
L2 = z(3)
a1 = Val(Text1.Text)
q = Val(Text2.Text)
E1 = Sqr(2 * q - q ^ 2)
E2 = Sqr(E1 ^ 2 / (1 - E1 ^ 2))
Bm = (B1 = B2) / 2
b = B2 - B1
l = L2 - L1
Mm = a1 * (1 - E1) / (Sqr(1 - E1 * (Sin(Bm)) ^ 2)) ^ 3
Nm = a1 * (1 - E1) / Sqr(1 - E1 * (Sin(Bm)) ^ 2)
t = Tan(Bm)
Vm = Sqr(1 + (E2 ^ 2 * (Cos(Bm)) ^ 2))
Y = E2 * Cos(Bm)
D1 = ((Nm * b) / Vm ^ 2) - (Nm * (Cos(Bm)) ^ 2 * (2 + 3 * t ^ 2 - 3 * t ^ 2 * Y ^ 2) * b * l ^ 2) / 24 - (Nm * (t ^ 2 * Y ^ 2 - Y ^ 2) * b ^ 3) / 8
D2 = Nm * Cos(Bm) * l + (Nm * Cos(Bm) * (1 - Y ^ 2 - 9 * t ^ 2 * Y ^ 2) * b ^ 2 * l) / 24 - (Nm * Cos(Bm) * (Sin(Bm)) ^ 2 * l ^ 3) / 24
Am = Atn(D2 / D1)
S = D2 / Sin(Am)
a = Sin(Bm) * l + (Sin(Bm) * (2 + 3 * Y ^ 2 + 9 * t ^ 2 * Y ^ 2) * b ^ 2 * l) / 24 + ((Cos(Bm)) ^ 3 * t * (2 + t ^ 2 + 2 * Y ^ 2) * l ^ 3) / 24
A12 = Am - (a / 2)
A21 = Am + (a / 2) + 3.1415926
If A21 > 6.2831852 Then
A21 = A21 - 6.2831852
End If
Text3(4).Text = Fix(A12 * 180 / 3.1415926) & "," & Fix(((A12 * 180 / 3.1415926) - Fix(A12 * 180 / 3.1415926)) * 60) & "," & ((((A12 * 180 / 3.1415926) - Fix(A12 * 180 / 3.1415926)) * 60) - Fix(((A12 * 180 / 3.1415926) - Fix(A12 * 180 / 3.1415926)) * 60)) * 60
Text3(5).Text = Fix(A21 * 180 / 3.1415926) & "," & Fix(((A21 * 180 / 3.1415926) - Fix(A21 * 180 / 3.1415926)) * 60) & "," & ((((A21 * 180 / 3.1415926) - Fix(A21 * 180 / 3.1415926)) * 60) - Fix(((A21 * 180 / 3.1415926) - Fix(A21 * 180 / 3.1415926)) * 60)) * 60
TextS.Text = Str(S)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -