nbtoxa.bas

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

Attribute VB_Name = "Module1"


Public DX As Double, DY As Double, DZ As Double
Public XS As Double, YS As Double, ZS As Double
Public XT As Double, YT As Double, ZT As Double
Public RX As Double, RY As Double, RZ As Double
Public L0 As Double, N0 As Double, q As Double, lll As Double
Public X0 As Double, Y0 As Double, Z0 As Double, H0 As Double, E1 As Double
Public xx2 As Double, yy2 As Double
Public xa As Double, ya As Double
Public Frame1 As Frame, Frame2 As Frame, Frame3 As Frame, Frame4 As Frame
Public Frame5 As Frame, Frame6 As Frame, Frame7 As Frame, Frame8 As Frame
Public i22 As Double, i23 As Double, i17 As Double, i18 As Double
Public e As Single, x1 As Double, y1 As Double, pi As Double
Public B0 As Double, b1 As Double, a As Double, p As Double
Public d As Double, f As Double, Z As Double
Public bi As Double, bf As Double, b As Double, c As Double, t As Double
Public v As Double, u As Double, h As Double, n As Double, M As Double
Public c1 As Double, c2 As Double, c3 As Double, l As Double, w As Double
Public K As Double, x3 As Double, x4 As Double, x5 As Double, x6 As Double
Public r3 As Double, r5 As Double, x2 As Double, y2 As Double
Public X As Double, Y As Double
Public bstr As String, pp As Double, j As Single
Public lstr As String
Public bbb As Double, FF As Double
Public lls2 As String, bbs2 As String
Public lo As Double, aw As Double
Public cc1 As Double, cc2 As Double, cc3 As Double, r As Double
Public objfile1 As File
Public objfile2 As File
Public objfile As File
Public filefilter As String, dianhao As String
Public fileflags As FileOpenConstants
Public GetFileName As String, hx(3) As Single, jihao As Single, i As Integer, xu As String
Public GetFileOpenName As String
Public GetFileSaveName As String
Sub nbtoxa() '宁波转换西安
 i22 = -33.27450647
 i23 = -48.90057789
 i17 = 0.00000312278
 i18 = 0.999996885
 xa = xa + 3200000#
 ya = ya - 600000#
 e = ya
 y1 = e
 x1 = xa
 pi = 3.14159265358979
 p = 180# / pi
 B0 = 111134#
 b1 = 0.861084
 a = 121.5
 d = 120#
 f = 0#
 fansuan '反算
 zhengsuan '正算
  If x2 < 1000000 Then x2 = x2 - 1 * 0.0005
  y2 = y2 + f + Sgn(y2 + f) * 0.0005
  y2 = y2 + 500000
  xx2 = i22 + i18 * x2 - i17 * y2
  yy2 = i23 + i17 * x2 + i18 * y2
  xx2 = FormatNumber(xx2, 3, vbFalse)
  yy2 = FormatNumber(yy2, 3, vbFalse)
 End Sub
Sub nbtobj() '宁波转换北京
 i22 = 55.856
 i23 = -38.736
 i17 = 1.43901766569147E-05
 i18 = 0.99998599
 xa = xa + 3200000#
 ya = ya - 600000#
 e = ya
 y1 = e
 x1 = xa
 pi = 3.14159265358979
 p = 180# / pi
 B0 = 111134#
 b1 = 0.861084
 a = 121.5
 d = 120#  '中央子午线
 f = 0#
 fansuan '反算
 zhengsuan '正算
 If x2 < 1000000 Then x2 = x2 - 1 * 0.0005
  y2 = y2 + f + Sgn(y2 + f) * 0.0005
  y2 = y2 + 500000#
  xx2 = i22 + i18 * x2 - i17 * y2
  yy2 = i23 + i17 * x2 + i18 * y2
  xx2 = FormatNumber(xx2, 3, vbFalse)
  yy2 = FormatNumber(yy2, 3, vbFalse)
   

End Sub

Sub xatonb() '西安转换宁波
 i22 = 33.27450647
 i23 = 48.90057789
 i17 = -0.00000312278
 i18 = 1.000003115
  xx2 = i22 + i18 * X - i17 * Y
  yy2 = i23 + i17 * X + i18 * Y
  xx2 = FormatNumber(xx2, 3, vbFalse)
  yy2 = FormatNumber(yy2, 3, vbFalse)
  x2 = xx2
  y2 = yy2
  e = yy2
 x1 = xx2
 y1 = e
 pi = 3.14159265358979
 p = 180# / pi
 B0 = 111134#
 b1 = 0.861084
 a = 120#
 d = 121.5
 f = 500#
 fansuan '反算
 zhengsuan '正算
 If x2 < 1000000 Then x2 = x2 - 1 * 0.0005
  x2 = x2 - 3200000#
  y2 = y2 + 600000#
  
  xx2 = FormatNumber(x2, 3, vbFalse)
  yy2 = FormatNumber(y2, 3, vbFalse)
End Sub
Sub bjtonb() '北京转换宁波

  i22 = -55.856
  i23 = 38.736
  i17 = -1.43901766569147E-05
  i18 = 1.00001401
  x2 = i22 + i18 * xa - i17 * ya
  y2 = i23 + i17 * xa + i18 * ya
  xa = x2
  ya = y2
  e = ya
  y1 = e
  x1 = xa
  pi = 3.14159265358979
  p = 180# / pi
  B0 = 111134#
  b1 = 0.861084
  a = 120#
  d = 121.5 '中央子午线
  f = 500#
  fansuan '反算
  zhengsuan '正算
  If x2 < 1000000 Then x2 = x2 - 1 * 0.0005
  y2 = y2 + f + Sgn(y2 + f) * 0.0005
  y2 = y2 + 100000#
  x2 = x2 - 3200000#
  xx2 = FormatNumber(x2, 3, vbFalse)
  yy2 = FormatNumber(y2, 3, vbFalse)
End Sub
 Sub bjtoxa() '北京转换西安
      i22 = -89.341
      i23 = -10.921
      i17 = -1.10592448683044E-05
      i18 = 1.00001099
      xx2 = i22 + i18 * x2 - i17 * y2
      yy2 = i23 + i17 * x2 + i18 * y2
      xx2 = FormatNumber(xx2, 3, vbFalse)
      yy2 = FormatNumber(yy2, 3, vbFalse)
End Sub
 Sub xatobj()
      i22 = 89.341
      i23 = 10.921
      i17 = 1.10592448683044E-05
      i18 = 0.99998901
      xx2 = i22 + i18 * x2 - i17 * y2
      yy2 = i23 + i17 * x2 + i18 * y2
      xx2 = FormatNumber(xx2, 3, vbFalse)
      yy2 = FormatNumber(yy2, 3, vbFalse)
End Sub

Sub zuobiaotojingwei() '坐标计算经纬度
   pi = 3.14159265358979
   pp = 180 / pi
   B0 = 111134
   b1 = 0.861084
   e = y1
 For j = 1 To 6
   q = 16036.48027 * Sin(2 * b / pp) - 16.82806688 * Sin(4 * b / pp) + 0.0219753 * Sin(6 * b / pp)
   bi = Int(b)
   bf = (x1 + q) / (B0 + b1) - bi
   b = bi + bf
 Next j
   e = y1
   f = 500
   f = f * 1000
   e = e - f
   Z = e * e
   c = Cos(b / pp)
   t = Tan(b / pp)
   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 * pp / 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 * pp / n / c * (1 - Z / 6 / M * (c1 - Z / 20 / M * (c2 - Z / 42 / M * c3)))
   bbb = b
   l = l + lo
   lll = l
   L0 = 120   '预转换的坐标系中央子午线
   l1 = l
   w = b
   a = 6378245: b = 6356863.0188
   p = 206265
   e = (a ^ 2 - b ^ 2) / (b ^ 2)
   tc = Tan(w / pp)
   wc = Cos(w / pp)
   n = e * wc ^ 2
   M = Abs(L0 - l1) * 3600
   u = 1 + (1 / (2 * p ^ 2)) * wc * (1 + n) * M ^ 2 + (1 / (24 * p ^ 4)) * wc ^ 2 * (5 - 4 * tc ^ 2) * M ^ 4
   pu = u ^ 2
   bb1 = Int(bbb)
  bb2 = Int((bbb - bb1) * 60)
  bb3 = ((bbb - bb1) * 60 - bb2) * 60
  If bb2 < 10 Then bbs2 = "0" & CStr(bb2)
  If bb2 = 0 Then bbs2 = "00"
  If bb2 >= 10 Then bbs2 = CStr(bb2)
  If bb3 < 1 Then bbs3 = "00" & CStr(FormatNumber(bb3, 4, vbFalse))
  If (bb3 < 10) And (bb3 > 1) Then bbs3 = "0" & CStr(FormatNumber(bb3, 4, vbFalse))
  If bb3 >= 10 Then bbs3 = CStr(FormatNumber(bb3, 4, vbFalse))
  bstr = CStr(bb1) & Chr(32) & bbs2 & Chr(32) & bbs3
  ll1 = Int(lll)
  ll2 = Int((lll - ll1) * 60)
  ll3 = ((lll - ll1) * 60 - ll2) * 60
  If (ll2 < 10) And (ll2 > 0) Then lls2 = "0" & CStr(ll2)
  If ll2 = 0 Then lls2 = "00"
  If ll2 >= 10 Then lls2 = CStr(ll2)
  If ll3 < 1 Then lls3 = "00" & CStr(FormatNumber(ll3, 4, vbFalse))
  If (ll3 < 10) And (ll3 > 1) Then lls3 = "0" & CStr(FormatNumber(ll3, 4, vbFalse))
  If ll3 >= 10 Then lls3 = CStr(FormatNumber(ll3, 4, vbFalse))
  lstr = CStr(ll1) & Chr(32) & lls2 & Chr(32) & lls3

End Sub
Sub huandai() '换带计算
  xa = x2
  ya = y2
  e = ya
  y1 = e
  x1 = xa
  pi = 3.14159265358979
  p = 180 / pi
  B0 = 111134
  b1 = 0.861084
  f = 500
  fansuan '反算
  zhengsuan '正算
  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 zuobiaozhengsuan() '坐标正算
  pi = 3.14159265358979
  p = 180# / pi
  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 = 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