nbtoxa.bas

可以在pocketpc上进行坐标换带计算以及坐标转换等功能

 y5 = 5 + h * (14 - 58 * u) + u * (u - 18)
 r3 = 1 + h * (3 + 2 * h)
 r5 = 2 - u
 q = 16036.48027 * Sin(2 * b / p) - 16.82806688 * Sin(4 * b / p) + 0.0219753 * Sin(6 * b / p)
 x2 = (B0 + b1) * (bi + bf) - q + t * n * v * K / 6 * (3 + v * K / 4 * (x4 + v * K / 30 * x6))
 y2 = n * c * w * (1 + v * K / 6 * (y3 + v * K / 20 * y5))
 r = w * p * t * c * (1 + v * K / 3 * (r3 + v * K / 5 * r5))
 If x2 < 1000000 Then x2 = x2 - 1 * 0.0005
  y2 = y2 + f + Sgn(y2 + f) * 0.0005
  xx2 = FormatNumber(x2, 3, vbFalse)
  yy2 = FormatNumber(y2, 3, vbFalse)
End Sub
Sub zhengsuan() '正算
 K = w * w
 c = Cos(b / p)
 t = Tan(b / p)
 v = c * c
 u = t * t
 h = 0.006738525415 * v
 n = 6399698.902 / Sqr(1 + h)
 M = n * n
 x4 = 5 - u + h * (9 + 4 * h)
 x6 = 61 + u * (u - 58)
 y3 = 1 - u + h
 y5 = 5 + h * (14 - 58 * u) + u * (u - 18)
 r3 = 1 + h * (3 + 2 * h)
 r5 = 2 - u
 q = 16036.48027 * Sin(2 * b / p) - 16.82806688 * Sin(4 * b / p) + 0.0219753 * Sin(6 * b / p)
 x2 = (B0 + b1) * (bi + bf) - q + t * n * v * K / 6 * (3 + v * K / 4 * (x4 + v * K / 30 * x6))
 y2 = n * c * w * (1 + v * K / 6 * (y3 + v * K / 20 * y5))
 r = w * p * t * c * (1 + v * K / 3 * (r3 + v * K / 5 * r5))
End Sub
Sub fansuan() '反算
 f = f * 1000
 e = e - f
 Z = e * e
 For j = 1 To 6
   q = 16036.48027 * Sin(2 * b / p) - 16.82806688 * Sin(4 * b / p) + 0.0219753 * Sin(6 * b / p)
   bi = Int(b)
   bf = (x1 + q) / (B0 + b1) - bi
   b = bi + bf
 Next j

 c = Cos(b / p)
 t = Tan(b / p)
 v = c * c
 u = t * t
 h = 0.006738525415 * v
 n = 6399698.902 / Sqr(1 + h)
 M = n * n
 '反算
 bf = bf - (1 + h) * t * Z * p / 2 / M * (1 - Z / 12 / M * (5 + u * (3 - 9 * h) + h - Z / 30 / M * (61 + 45 * u * (2 + u))))
 b = bi + bf
 c1 = 1 + 2 * u + h
 c2 = 5 + h * (6 + 8 * u) + u * (28 + 24 * u)
 c3 = 61 + u * (662 + u * (1320 + 720 * u))
 l = e * p / n / c * (1 - Z / 6 / M * (c1 - Z / 20 / M * (c2 - Z / 42 / M * c3)))
 s = d - a
 w = (l - s) / p
End Sub
Public Sub ShowFrame()
    Form3.Frame1.Visible = False
    Form3.Frame2.Visible = False
    Form3.Frame3.Visible = False
    Form3.Frame4.Visible = False
    Form3.Frame5.Visible = False
    Form3.Frame6.Visible = False
  
End Sub

Public Sub ShowformAFrame()
    Form2.Frame1.Visible = False
    Form2.Frame2.Visible = False
    Form2.Frame3.Visible = False
    Form2.Frame4.Visible = False
    Form2.Frame5.Visible = False
    Form2.Frame6.Visible = False
End Sub
Public Sub Showform9Frame()
    Form9.Frame1.Visible = False
    Form9.Frame2.Visible = False
    Form9.Frame3.Visible = False
   ' Form9.Frame4.Visible = False
   ' Form9.Frame5.Visible = False
   ' Form9.Frame6.Visible = False
End Sub

Public Function deg(a As Double)
  cc1 = Int(a)
  cc2 = Int((a - cc1) * 100)
  cc3 = ((a * 100 - cc1 * 100 - cc2) * 100)
  aw = cc1 + cc2 / 60 + cc3 / 3600
End Function
Public Function dms(a As Double)
  cc1 = 0: cc2 = 0: cc3 = 0
  bbs1 = "": bbs2 = "": bbs3 = ""
  cc1 = Int(Abs(a))
  cc2 = Int((Abs(a) - cc1) * 60)
  cc3 = ((Abs(a) - cc1) * 60 - cc2) * 60
  If Sgn(a) = -1 Then bbs1 = "-" & CStr(cc1)
  If Sgn(a) <> -1 Then bbs1 = CStr(cc1)
  If cc2 < 10 Then bbs2 = "0" & CStr(cc2)
  If cc2 = 0 Then bbs2 = "00"
  If cc2 >= 10 Then bbs2 = CStr(cc2)
  If cc3 < 1 Then bbs3 = "00" & CStr(FormatNumber(cc3, 6, vbFalse))
  If (cc3 < 10) And (cc3 > 1) Then bbs3 = "0" & CStr(FormatNumber(cc3, 6, vbFalse))
  If cc3 >= 10 Then bbs3 = CStr(FormatNumber(cc3, 6, vbFalse))
  bstr = bbs1 & Chr(32) & bbs2 & Chr(32) & bbs3
End Function

Sub BLTOXY() ' BJ54空间坐标反算大地坐标

   pi = 3.14159265358979
   p = 180# / pi
   a = 6378245#
   f = 1 / 298.3

l = Atn(Y / X)
b = Atn(Z / Sqr(X ^ 2 + Y ^ 2))
For i = 1 To 6
N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(b) * Sin(b))
b = Atn((Z + N0 * (2 * f - f ^ 2) * Sin(b)) / Sqr(X ^ 2 + Y ^ 2))
Next i
N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(b) * Sin(b))
H0 = Sqr(X ^ 2 + Y ^ 2) / Cos(b) - N0
End Sub
Sub WGS84BLH()
 pi = 3.14159265358979 ' WGS 84空间坐标反算大地坐标
 p = 180# / pi
 a = 6378137#
 f = 1 / 298.257223563
 l = Atn(Y / X)
 b = Atn(Z / Sqr(X ^ 2 + Y ^ 2))
For i = 1 To 6
 N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(b) * Sin(b))
 b = Atn((Z + N0 * (2 * f - f ^ 2) * Sin(b)) / Sqr(X ^ 2 + Y ^ 2))
Next i
 N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(b) * Sin(b))
 H0 = Sqr(X ^ 2 + Y ^ 2) / Cos(b) - N0

End Sub

Sub WGS84XYH()

 pi = 3.14159265358979 'WGS84大地坐标转空间坐标
 p = 180# / pi
 a = 6378137#
 b = 6356752.314
 f = 1 / 298.257223563
 N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(B0 / p) * Sin(B0 / p))
 X0 = (N0 + H0) * Cos(B0 / p) * Cos(L0 / p)
 Y0 = (N0 + H0) * Cos(B0 / p) * Sin(L0 / p)
 Z0 = (N0 * (1 - (2 * f - f ^ 2)) + H0) * Sin(B0 / p)
End Sub

Sub BJ54XYH()

 pi = 3.14159265358979 ' BJ54空间坐标反算大地坐标
   p = 180# / pi
   a = 6378245#
   f = 1 / 298.3
 N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(B0 / p) * Sin(B0 / p))
 X0 = (N0 + H0) * Cos(B0 / p) * Cos(L0 / p)
 Y0 = (N0 + H0) * Cos(B0 / p) * Sin(L0 / p)
 Z0 = (N0 * (1 - (2 * f - f ^ 2)) + H0) * Sin(B0 / p)
End Sub
Sub XYTOBL80()

   pi = 3.14159265358979 '国家80坐标转大地坐标
   p = 180# / pi
   a = 6378140#
   f = 1 / 298.25722101

l = Atn(Y / X)
b = Atn(Z / Sqr(X ^ 2 + Y ^ 2))
For i = 1 To 6
N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(b) * Sin(b))
b = Atn((Z + N0 * (2 * f - f ^ 2) * Sin(b)) / Sqr(X ^ 2 + Y ^ 2))
Next i
N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(b) * Sin(b))
H0 = Sqr(X ^ 2 + Y ^ 2) / Cos(b) - N0
End Sub
Sub WGS80XYH() '国家80大地坐标转空间坐标
 pi = 3.14159265358979
 p = 180# / pi
 a = 6378140#
 f = 1 / 298.25722101
 N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(B0 / p) * Sin(B0 / p))
 X0 = (N0 + H0) * Cos(B0 / p) * Cos(L0 / p)
 Y0 = (N0 + H0) * Cos(B0 / p) * Sin(L0 / p)
 Z0 = (N0 * (1 - (2 * f - f ^ 2)) + H0) * Sin(B0 / p)
End Sub
Sub zuobiao80zhengsuan() '国家80坐标正算
   pi = 3.14159265358979
   p = 180# / pi
   a = 6378140#
   FF = 1 / 298.25722101
   B0 = 111134#
  b1 = 0.861084
  f = 500#
  f = f * 1000
 
 bi = Int(b)
 bf = b - bi
 l1 = Int(l) - lo
 l = l1 + l - Int(l)
  w = l / p
  K = w * w
 c = Cos(b / p)
 t = Tan(b / p)
 v = c * c
 u = t * t
 h = 6.73950181947292E-03 * v
' x4 = (2 * FF - FF ^ 2) / (1 - (2 * FF - FF ^ 2))
 'MsgBox x4
' h = (2 * FF - FF ^ 2) * v
 n = 6399698.902 / Sqr(1 + h)
 ' n = a / Sqr(1 - (2 * FF - FF ^ 2) * Sin(b / p) * Sin(b / p))
 M = n * n
 x4 = 5 - u + h * (9 + 4 * h)
 x6 = 61 + u * (u - 58)
 y3 = 1 - u + h
 y5 = 5 + h * (14 - 58 * u) + u * (u - 18)
 r3 = 1 + h * (3 + 2 * h)
 r5 = 2 - u
 q = 16036.48027 * Sin(2 * b / p) - 16.82806688 * Sin(4 * b / p) + 0.0219753 * Sin(6 * b / p)
 x2 = (B0 + b1) * (bi + bf) - q + t * n * v * K / 6 * (3 + v * K / 4 * (x4 + v * K / 30 * x6))
 y2 = n * c * w * (1 + v * K / 6 * (y3 + v * K / 20 * y5))
 r = w * p * t * c * (1 + v * K / 3 * (r3 + v * K / 5 * r5))
 If x2 < 1000000 Then x2 = x2 - 1 * 0.0005
  y2 = y2 + f + Sgn(y2 + f) * 0.0005
  xx2 = FormatNumber(x2, 3, vbFalse)
  yy2 = FormatNumber(y2, 3, vbFalse)
  
  'DX = 14.36718
'DY = -14.481813
'DZ = -21.978301
'RX = 0.0000040107
'RY = -0.000007843
'RZ = 0.0000162312
'K = -0.00000042018
'M = 1 + K
'If IsNumeric(Text16) = False Then Text16.Text = "": Text16.SetFocus: Exit Sub
'If IsNumeric(Text17) = False Then Text17.Text = "": Text17.SetFocus: Exit Sub
'If IsNumeric(Text18) = False Then Text18.Text = "": Text18.SetFocus: Exit Sub
'If CDbl(Text18.Text) >= 180 Then MsgBox "纬度不能大于180度", vbExclamation, "WGS84坐标转换西安80坐标": Text18.Text = "": Text18.SetFocus: Exit Sub
'If CDbl(Text17.Text) >= 180 Then MsgBox "经度不能大于180度", vbExclamation, "WGS84坐标转换西安80坐标": Text17.Text = "": Text17.SetFocus: Exit Sub
 'B0 = CDbl(Text18)
 'deg (B0)
 'B0 = aw
 'L0 = CDbl(Text17)
 'deg (L0)
 'L0 = aw
 'H0 = CDbl(Text16)
 'WGS84XYH
'XS = X0
'YS = Y0
'ZS = Z0
'XT = M * (XS + RZ * YS - RY * ZS) + DX
'YT = M * (-RZ * XS + YS + RX * ZS) + DY
'ZT = M * (RY * XS - RX * YS + ZS) + DZ
'X = XT
'Y = YT
'Z = ZT
'MsgBox XT
'MsgBox YT
'XYTOBL80
'b = b * p
'dms (b)
'MsgBox bstr
'l = l * p + 180
'dms (l)
'MsgBox bstr
'b = 29.89448731
'l = 121.314088
'
'lo = 120
'zuobiao80zhengsuan
'Text15.Text = CStr(xx2)
'Text14.Text = CStr(yy2)
'Text13.Text = CStr(FormatNumber(H0, 3))
End Sub