module1.bas

GPS坐标转换软件：直角坐标与大地坐标转换

Attribute VB_Name = "Module1"
Sub uvwtowrh(uvw)
Dim u As Double                           '直角坐标系X坐标
Dim v As Double                           '直角坐标系Y坐标
Dim ww As Double                           '直角坐标系Z坐标
Dim N As Double                           'n＝a/w
Dim limit As Double                       '限值
Dim esq As Double                         'sqrt(a*a-b*b)/a

u = uvw(1)
v = uvw(2)
ww = uvw(3)
esq = 2 * fell - fell * fell                         '求e=sqrt(a*a-b*b)/a

If ((u = 0) Or (v = 0)) Then
    omuga = 0
Else
    d = (1 - esq) * Sqr(u * u + v * v)
    omuga1 = Atn(w / d)
    j = 0
    e = 1000000#
    limit = 0.000001 / (3600#) * deg
    Do While e > limit
       N = aell / Sqr(1 - esq * Sin(omuga1) * Sin(omuga1))
       omuga = Atn((ww / Sqr(u * u + v * v)) * (1 + esq * N * Sin(omuga1) / ww))
       e = Abs(omuga1 - omuga)
       omuga1 = omuga
       j = j + 1
       If j > 10 Then Exit Do
    Loop
End If

If (u = 0) And (v = 0) Then
    riga = 0
End If

If (u > 0) And (v >= 0) Then
    riga = Atn(v / u)
End If

If (u < 0) Then
    riga = 3.1415926 + Atn(v / u)
End If

If (u > 0) And (v <= 0) Then
    riga = 2 * 3.1415926 + Atn(v / u)
End If

If (u = 0) And (v > 0) Then
    riga = 3.1415926 / 2
End If

If (u = 0) And (v < 0) Then
    riga = 1.5 * 3.1415926
End If
hhh = Sqr(u * u + v * v) / Cos(omuga) - N
riga = riga / deg
omuga = omuga / deg


End Sub


Sub wrhtouvw(wrh)
Dim N As Double                           'n＝a/w
Dim ww1 As Double
Dim rr1 As Double
Dim hh1 As Double
Dim esq As Double

esq = 2 * fell - fell * fell                         '求e=sqrt(a*a-b*b)/a
ww1 = wrh(1) * deg
rr1 = wrh(2) * deg
hh1 = wrh(3)
N = aell / Sqr(1 - esq * Sin(ww1) * Sin(ww1))
xx1 = (N + hh1) * Cos(ww1) * Cos(rr1)
yy1 = (N + hh1) * Cos(ww1) * Sin(rr1)
zz1 = (N * (1 - esq) + hh1) * Sin(ww1)

End Sub

Sub uvwtowrh2(uvw)
Dim u As Double                           '直角坐标系X坐标
Dim v As Double                           '直角坐标系Y坐标
Dim ww As Double                           '直角坐标系Z坐标
Dim N As Double                           'n＝a/w
Dim limit As Double                       '限值
Dim esq As Double                         'sqrt(a*a-b*b)/a
Dim b As Double
Dim N1 As Double
Dim omuga1 As Double
Dim hhh1 As Double
Dim dd As Double


u = uvw(1)
v = uvw(2)
ww = uvw(3)
esq = 2 * fell - fell * fell                         '求e=sqrt(a*a-b*b)/a
b = aell * Sqr(1 - esq)
N = aell
hhh = Sqr(u ^ 2 + v ^ 2 + ww ^ 2) - Sqr(aell * b)
omuga = Atn(ww / (Sqr(u ^ 2 + v ^ 2) * (1 - esq * N / (N + hhh))))



Do
    hhh1 = hhh
    N = aell / Sqr(1 - esq * Sin(omuga) * Sin(omuga))
    hhh = Sqr(u ^ 2 + v ^ 2) / Cos(omuga) - N
    omuga = Atn(ww / (Sqr(u ^ 2 + v ^ 2) * (1 - esq * N / (N + hhh))))
    dd = Abs(hhh1 - hhh)
    If dd < 0.001 Then Exit Do
Loop

If (u = 0) And (v = 0) Then
    riga = 0
End If

If (u > 0) And (v >= 0) Then
    riga = Atn(v / u)
End If

If (u < 0) Then
    riga = 3.1415926 + Atn(v / u)
End If

If (u > 0) And (v <= 0) Then
    riga = 2 * 3.1415926 + Atn(v / u)
End If

If (u = 0) And (v > 0) Then
    riga = 3.1415926 / 2
End If

If (u = 0) And (v < 0) Then
    riga = 1.5 * 3.1415926
End If
riga = riga / deg
omuga = omuga / deg




End Sub