高斯投影坐标正反算及相邻带的坐标换算VB编程.docx

1、高斯投影坐标正反算及相邻带的坐标换算VB编程高斯投影坐标正反算及相邻带的坐标换算VB编程Private Sub Command1_Click()Form1.HideForm2.ShowEnd SubPrivate Sub Command2_Click()Form1.HideForm3.ShowEnd SubPublic a#, c#, ee1#, ee#, a0#, a2#, a4#, a6#, a8#, q0#, q2#, q4#, q6#, q8#, p0#Public Function fd(ByVal g As Double) As Double Dim mm As Double, d

2、d&, ii& p0 = 57.2957795513082 g = g + 1E-19 *弧度转换 dd = Fix(g) ii = Fix(g - dd) * 100) mm = (g - dd) * 100 - ii mm = dd + ii / 60 + mm / 36 fd = mm / p0End FunctionPrivate Sub Command1_Click()Dim a As StringCommonDialog1.ShowOpen *查找路径Text4.Text = CommonDialog1.FileNameEnd SubPrivate Sub Command2_Cli

3、ck()Dim h#, k#, s#If Text4.Text ThenOpen Text4.Text For Input As #1 *读入数据Do While Not EOF(1) Input #1, h, k, s List1.AddItem h List2.AddItem k List3.AddItem sLoopClose #1Else Style = vbExclamation + vbOKOnly r = MsgBox(没有指定路径, Style, 错误提示)End IfEnd SubPrivate Sub Command3_Click()If List1.ListCount =

4、 0 Or List2.ListCount = 0 Or List3.ListCount = 0 Then *主过程 Style = vbExclamation + vbOKOnly r = MsgBox(没有找到数据, Style, 错误提示)Else If Option1.Value = False And Option2.Value = False And Option3.Value = False Then Style = vbExclamation + vbOKOnly r = MsgBox(没有选择椭球, Style, 错误提示) Else Open d:正算结果.txt For

5、Output As #1 Print #1, X & Chr(44); Spc(18); Y & Chr(44); Spc(24); r0 Close #1 Dim x1#, p#, r0#, t#, w2#, v2#, N#, l0#, p0#, t2#, p2#, rr$, x#, y#, b#, j#, j0#, B0# *正算 For i = 0 To List1.ListCount - 1 p0 = 57.2957795513082 b = fd(Val(List1.List(i) B0 = b * p0 j = fd(Val(List2.List(i) j0 = fd(Val(Li

6、st3.List(i) t = Tan(b) w2 = ee1 * (Cos(b) 2 N = c / Sqr(1 + w2) l0 = j - j0 x1 = a0 * B0 + a2 * Sin(2 * b) + a4 * Sin(4 * b) + a6 * Sin(6 * b) + a8 * Sin(8 * b) p = Cos(b) * l0 / p0 t2 = t 2 p2 = p 2 s1# = (9 + 4 * w2) * w2 s2# = (t2 - 58) * t2 s3# = (9 - 11 * t2) * 30 * w2 s4# = (543 - t2) * t2 x =

7、 x1 + N * t * (1 + (5 - t2 + s1) + (61 + s2 + s3) + (1385 + (-3111 + s4) * t2) * p2 / 56) * p2 / 30) * p2 / 12) * p2 / 2 m1# = 1 - t2 + w2 m2# = t2 * (t2 - 18 - 58 * w2) m3 = (179 - t2) * t2 y = N * (1 + (m1 + (5 + m2 + 14 * w2) + (61 + (-479 + m3) * t2) * p2 / 42) * p2 / 20) * p2 / 6) * p k1# = w2

8、* (3 + 2 * w2) k2# = 15 * w2 * (1 - t 3) k3# = 2 * (t2 - 13) * t2 r0 = (Sin(b) * l0 * (1 + (1 + k1) + (2 - t2 + k2) + (17 + k3) * p2 / 21) * p2 / 5) * p2 / 3) * p0 If r0 0 Then rr = Fix(r0) & & Fix(r0 - Fix(r0) * 60) & & (r0 - Fix(r0) * 60 - Fix(r0 - Fix(r0) * 60) * 60 Else r0 = -r0 rr = - & Fix(r0)

9、 & & Fix(r0 - Fix(r0) * 60) & & (r0 - Fix(r0) * 60 - Fix(r0 - Fix(r0) * 60) * 60 End If List4.AddItem x List5.AddItem y List6.AddItem rr Dim h#, k#, s$ Open d:正算结果.txt For Append As #1 h = List4.List(i): k = List5.List(i): s = List6.List(i) Print #1, h & Chr(44); Spc(3); k & Chr(44); Spc(9); s Close

10、 #1 Next Style = vbExclamation + vbOKOnly r = MsgBox(已输出正算结果到D：目录下, Style, 提示) End IfEnd IfEnd SubPrivate Sub Command4_Click()If List4.ListCount = 0 Or List5.ListCount = 0 Then *主过程 Style = vbExclamation + vbOKOnly r = MsgBox(没有找到数据, Style, 错误提示)Else If Option1.Value = False And Option2.Value = Fals

11、e And Option3.Value = False Then Style = vbExclamation + vbOKOnly r = MsgBox(没有选择椭球, Style, 错误提示) Else Open d:反算结果.txt For Output As #1 Print #1, 经度 & Chr(44); Spc(17); 维度 & Chr(44); Spc(23); r0 Close #1 Dim B0#, Bf#, Bf0#, b#, l0#, r0#, wf2#, tf#, Nf#, q#, y0#, x0#, p0#, tf2#, q2#, Bf1#, L# *反算 For

12、 i = 0 To List4.ListCount - 1 p0 = 57.2957795513082 y0 = Val(List5.List(i) x0 = Val(List4.List(i) L = Val(List3.List(i) B0 = x0 * q0 Bf = B0 + Sin(2 * B0) * q2 + Sin(2 * B0) * Sin(B0) 2 * (q4 + Sin(B0) 2 * q6 + (Sin(B0) 2) 2 * q8) Bf0 = Bf * p0 tf = Tan(Bf) wf2 = ee1 * Cos(Bf) 2 vf2 = 1 + wf2 Nf = c

13、 / Sqr(vf2) q = y0 / Nf tf2 = tf 2 q2 = q 2 b = Bf0 + p0 * tf * (-vf2 + (5 + 3 * tf2 * (1 + (-2 - 3 * wf2) * wf2) + 3 * wf2 * (2 - wf2) + (-(61 + 45 * tf2 * (2 + tf2) + (107 + (-162 - 45 * tf2) * tf2) * wf2) + (1385 + (3633 + (4095 + 1575 * tf2) * tf2) * tf2) * q2 / 56) * q2 / 30) * q2 / 12) * q2 /

14、2 k1# = 1 + 2 * tf2 + wf2 k2# = 4 * tf2 * (7 + 6 * tf2) k3# = 2 * wf2 * (3 + 4 * tf2) k4# = (1320 + 720 * tf2) * tf2 l0 = p0 * q / Cos(Bf) * (1 + (-k1 + (5 + k2 + k3) - (61 + (662 + k4) * tf2) * q2 / 42) * q2 / 20) * q2 / 6) + L m1# = wf2 * (1 + 2 * wf2) m2# = tf2 * (5 + 3 * tf2) m3# = wf2 * (2 + tf

15、2) m4# = (105 + 45 * tf2) * tf2 r0 = p0 * q * tf * (1 + (-(1 + tf2 - m1) + (2 + m2 + m3) - (17 + (77 + m4) * tf2) * q2 / 21) * q2 / 5) * q2 / 3) List1.AddItem b List2.AddItem l0 List6.AddItem r0 If r0 0 Then rr = Fix(r0) & & Fix(r0 - Fix(r0) * 60) & & (r0 - Fix(r0) * 60 - Fix(r0 - Fix(r0) * 60) * 60

16、 Else r0 = -r0 rr = - & Fix(r0) & & Fix(r0 - Fix(r0) * 60) & & (r0 - Fix(r0) * 60 - Fix(r0 - Fix(r0) * 60) * 60 End If Dim h#, k#, s$ Open d:反算结果.txt For Append As #1 h = List4.List(i): k = List5.List(i): s = List6.List(i) Print #1, h & Chr(44); Spc(3); k & Chr(44); Spc(9); s Close #1 Next Style = v

17、bExclamation + vbOKOnly r = MsgBox(已输出反算结果到D:目录下, Style, 提示) End IfEnd IfEnd SubPrivate Sub Command5_Click()Form2.HideForm1.ShowEnd SubPrivate Sub Label8_Click()End SubPrivate Sub Command6_Click()Unload Me Load Me Me.ShowLoad MeEnd SubPrivate Sub Command7_Click()Dim h#, k#, s#If Text4.Text ThenOpen

18、Text4.Text For Input As #1 *读入数据Do While Not EOF(1) Input #1, h, k, s List4.AddItem h List5.AddItem k List3.AddItem sLoopClose #1Else Style = vbExclamation + vbOKOnly r = MsgBox(没有指定路径, Style, 错误提示)End IfEnd SubPrivate Sub Option1_Click() a = 6378245 *克氏椭球 c = 6399698.90178271 ee1 = 6.738525414683 *

19、 10 -3 ee = 6.693421622966 * 10 -3 a0 = 111134.8610828 a2 = -16036.48022 a4 = 16.82805 a6 = -2.197 * 10 -2 a8 = 3 * 10 -5 q0 = 157046064.12328 * 10 -15 q2 = 2525886946.8158 * 10 -12 q4 = -14919317.6572 * 10 -12 q6 = 120717.4265 * 10 -12 q8 = -1075.1509 * 10 -12End SubPrivate Sub Option2_Click() a =

20、6378140 *1975椭球 c = 6399596.65198801 ee1 = 6.739501819473 * 10 -3 ee = 6.694384999588 * 10 -3 a0 = 111134.0046793 a2 = -16038.52818 a4 = 16.83263 a6 = -2.198 * 10 -2 a8 = 3 * 10 -5 q0 = 157048687.47416 * 10 -15 q2 = 2526252791.9786 * 10 -12 q4 = -14923644.4356 * 10 -12 q6 = 120769.9608 * 10 -12 q8 =

21、 -1075.77 * 10 -12End SubPrivate Sub Option3_Click() a = 6378137 *84椭球 c = 6399593.6258 ee1 = 6.73949674227 * 10 -3 ee = 6.694799013 * 10 -3 a0 = 111132.9525494 a2 = -16038.5084 a4 = 16.8326 a6 = -2.198 * 10 -2 a8 = 3 * 10 -5 q0 = 157048761.142065 * 10 -15 q2 = 2526250855.8867 * 10 -12 q4 = -1492362

22、1.5362 * 10 -12 q6 = 120769.6828 * 10 -12 q8 = -1075.7667 * 10 -12End SubPrivate Sub Command1_Click()If Option1.Value = False And Option2.Value = False And Option3.Value = False Thenr = MsgBox(请选择椭球参数, vbExclamation + vbOKOnly, 提示)End IfIf Text1.Text = Or Text2.Text = Or Text3.Text & Text4.Text & Te

23、xt5.Text = Or Text6.Text & Text7.Text & Text8.Text = Then r = MsgBox(没有数据或数据不完整, vbExclamation + vbOKOnly, 提示)ElseDim x, y, x1, x2, y2, p, B, l2, l, L, L1, L2, c, e, tf, tf2, wf, wf2, Vf, Nf, q, q2, B0, Bf, Bf, g, h, i, a, b, c As Doubleg = Val(Text3.Text): h = Val(Text4.Text): i = Val(Text5.Text)a

24、= Val(Text6.Text): b = Val(Text7.Text): c = Val(Text8.Text)p = 57.2957795130823L1 = (g + h / 60 + i / 3600) / pL2 = (a + b / 60 + c / 3600) / px = Val(Text1.Text): y = Val(Text2.Text)If Option1.Value = True And Option2.Value = False And Option3.Value = False ThenB0 = 157046064.12328 * 10 (-15) * xBf

25、 = B0 + Sin(2 * B0) * 2525886946.8158 * 10 (-12) + Sin(2 * B0) * (Sin(B0) 2 * (-14919317.6572 * 10 (-12) + (Sin(B0) 2 * (120717.4265 * 10 (-12) - 1075.1509 * 10 (-12) * (Sin(B0) 2)Bf = Bf * pe = Sqr(6.738525414683 * 10 -3)c = 6399698.90178271tf = Tan(Bf): tf2 = tf 2: wf = e * Cos(Bf): wf2 = wf 2: Vf

26、 = Sqr(1 + wf 2): Nf = c / Vfq = y / NfB = Bf + p * tf * (-Vf 2 + (5 + 3 * tf2 * (1 + (-2 - 3 * wf2) * wf2) + 3 * wf2 * (2 - wf2) + (-(61 + 45 * tf2 * (2 + tf2) + (107 + (-162 - 45 * tf2) * tf2) * wf2) + (1385 + (3633 + (4095 + 1575 * tf2) * tf2) * tf2) * q 2 / 56) * q 2 / 30) * q 2 / 12) * q 2 / 2l

27、2 = p * q / Cos(Bf) * (1 + (-(1 + 2 * tf2 + wf2) + (5 + 4 * tf2 * (7 + 6 * tf2) + 2 * wf2 * (3 + 4 * tf2) - (61 + (662 + (1320 + 720 * tf2) * tf2) * tf2) * q 2 / 42) * q 2 / 20) * q 2 / 6)L = L1 + l2t = Tan(B / p): t2 = t 2: l = L - L2p = Cos(B / p) * l / pp2 = p 2w = (e * Cos(B / p): w2 = w 2: V =

28、Sqr(1 + w 2): N = c / Vx1 = 111134.8610828 * B - 16036.48022 * Sin(2 * B / p) + 16.82805 * Sin(4 * B / p) - 0.02197 * Sin(6 * B / p) + 0.00003 * Sin(8 * B / p)x2 = x1 + N * t * (1 + (5 - t2 + (9 + 4 * w2) * w2) + (61 + (t2 - 58) * t2 + (9 - 11 * t2) * 30 * w2) + (1385 + (-3111 + (543 - t2) * t2) * t

29、2) * p2 / 56) * p2 / 30) * p2 / 12) * p2 / 2y2 = N * (1 + (1 - t2 + w2) + (5 + t2 * (t2 - 18 - 58 * w2) + 14 * w2) + (61 + (-479 + (179 - t2) * t2) * t2) * p2 / 42) * p2 / 20) * p2 / 6) * pEnd IfIf Option1.Value = False And Option2.Value = True And Option3.Value = False ThenB0 = 157048687.47416 * 10 (-15) * xBf = B0 + Sin(2 * B0) * 2526252791.9786 * 10 (-12) + Sin(2 * B0) * (Sin(B0) 2 * (-14923644.4356 * 10 (-12) + (Sin(B0) 2 * (120769.9608 * 10 (-12) - 1075.77 * 10 (-12) * (Sin(B0) 2)Bf = Bf * pe = Sqr(6.739501819473 * 10 -3)c = 6399596.65198801tf = Tan(Bf): tf2 = tf 2: w