module1.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
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 kongbj54ddtokong()
Dim pi As Double, pp As Double, p As Double, a As Double
   Dim b As Double, e As Double, b0 As Double, L0 As Double, N0 As Double
   Dim X0 As Double, Y0 As Double, Z0 As Double, H0 As Double, E1 As Double
   Dim f As Double
   pi = 3.14159265358979
   pp = 180# / pi
   p = 206265#
   a = 6378245#
   b = 6356863.0188
   ' e = 0.006738525415
 'N0 = 6399698.902 / Sqr(1 + h)
   f = 1 / 298.3
  'e = (a ^ 2 - b ^ 2) / (b ^ 2)
   b0 = 30
   L0 = 121
   H0 = 27.356
   N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(b0 / pp) * Sin(b0 / pp))
   X0 = (N0 + H0) * Cos(b0 / pp) * Cos(L0 / pp)
   Y0 = (N0 + H0) * Cos(b0 / pp) * Sin(L0 / pp)
   Z0 = (N0 * (1 - (2 * f - f ^ 2)) + H0) * Sin(b0 / pp)
    MsgBox X0
    MsgBox Y0
    MsgBox Z0
    MsgBox e
    MsgBox E1
End Sub



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
 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 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, 4, vbFalse))
  If cc3 >= 10 Then bbs3 = CStr(FormatNumber(cc3, 6, vbFalse))
  bstr = bbs1 & Chr(32) & bbs2 & Chr(32) & bbs3
End Function
Sub BLTOXY()

   pi = 3.14159265358979 ' WGS 84空间坐标反算大地坐标
   p = 180# / pi
   
   a = 6378245#
   b = 6356863.0188
   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))
h = Sqr(X ^ 2 + Y ^ 2) / Cos(b) - N0
dms (b * p)
MsgBox bstr
dms (l * p + 180)
MsgBox bstr
MsgBox h

End Sub
Sub WGS84BLH()
 pi = 3.14159265358979 ' WGS 84空间坐标反算大地坐标
   pp = 180# / pi
   a = 6378137#
   b = 6356752.314
   f = 1 / 298.257223563

X = -2795746.096
Y = 4707099.755
z = 3261334.812
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))
h = Sqr(X ^ 2 + Y ^ 2) / Cos(b) - N0
dms (b * pp)
MsgBox bstr
dms (l * pp + 180)
MsgBox bstr
MsgBox h
End Sub

Sub WGS84XYH()
 
b0 = 30.0613593876
      deg (b0)
      b0 = aw
         L0 = 121.0930033132
      deg (L0)
 L0 = aw
 H0 = 37.4433
   ' x1 = 3425907.456 '北京直角坐标系
   ' y1 = 567563.807
   ' zuobiaotojingwei
   ' b0 = bbb
   ' L0 = 120 + lll
   pi = 3.14159265358979
   pp = 180# / pi
   a = 6378137#
   b = 6356752.314
   f = 1 / 298.257223563
   H0 = 27.356
   N0 = a / Sqr(1 - (2 * f - f ^ 2) * Sin(b0 / pp) * Sin(b0 / pp))
   X0 = (N0 + H0) * Cos(b0 / pp) * Cos(L0 / pp)
   Y0 = (N0 + H0) * Cos(b0 / pp) * Sin(L0 / pp)
   Z0 = (N0 * (1 - (2 * f - f ^ 2)) + H0) * Sin(b0 / pp)
    MsgBox X0
    MsgBox Y0
    MsgBox Z0
    MsgBox e
    MsgBox E1
End Sub