Attribute VB_Name = "modTopo"
'***************************************************************************************************
' modTopo Module
'(C) 2002 Jean-Claude Vaillant
'***************************************************************************************************

Option Explicit

'***************************************************************************************************

Public g_dblCurrentLongitude As Double
Public g_dblCurrentLatitude As Double

Public Enum TopoScale
   tsc50 = 50
   tsc250 = 250
End Enum

Public Const g_dblOriginLongitude As Double = -144#
Public Const g_dblOriginLatitude As Double = 68#

Public Const g_dbl250kCoordWidth As Double = 2#
Public Const g_dbl250kCoordHeight As Double = 1#

Public Const g_dbl50kCoordWidth As Double = 2# / 4#
Public Const g_dbl50kCoordHeight As Double = 1# / 4#

Public Const g_lngRgnCols As Long = 12
Public Const g_lngRgnRows As Long = 7

Public Const g_lng250kCols As Long = 4 * g_lngRgnCols
Public Const g_lng250kRows As Long = 4 * g_lngRgnRows

Public Const g_lng50kCols As Long = 4 * g_lng250kCols
Public Const g_lng50kRows As Long = 4 * g_lng250kRows

Public Const m_strMapGrid As String = "mnoplkjiefghdcba"

'***************************************************************************************************

'Ellipsoid  WGS84
'1/f        298.2572236
'f          0.0033528107
'r          6378.137

' Since the earth’s radius varies between about 6,378km (equatorial) and 6,356km (polar),
' errors might be up to about 0.11% at the equator (0.24% at the poles, but marginal in temporate zones).
' It that’s not good enough (but who has latitude/longitude co-ordinates so accurately anyway?),
' the ellipsoidal (or more exactly, oblate spheroidal) shape of the earth could be approximated by using
' R = 6378 - 22.sin((lat1+lat2)/2).

Private Const dblRayon As Double = 6378.137
Private Const dblPI As Double = 3.14159265358979

'***************************************************************************************************

Private Function acos(ByVal dblValue As Double) As Double
    On Error GoTo acos_err
    acos = Atn(Sqr(1 - dblValue ^ 2) / dblValue)
acos_exit:
    On Error GoTo 0
    Exit Function
acos_err:
    acos = 0
    Resume acos_exit
End Function

'***************************************************************************************************

Private Function radians(ByVal dblValue As Double) As Double
    radians = dblValue * dblPI / 180#
End Function

'***************************************************************************************************

Public Function Distance(ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double) As Double
    Distance = dblRayon _
             * acos(Sin(radians(Y1)) _
                  * Sin(radians(Y2)) _
                  + Cos(radians(Y1)) _
                  * Cos(radians(Y2)) _
                  * Cos(radians(X2) _
                      - radians(X1)))
End Function

'***************************************************************************************************

Private Function XYtoLetter(ByVal X As Long, ByVal Y As Long) As String
    XYtoLetter = Mid$(m_strMapGrid, X + (Y * 4) + 1, 1)
End Function

'***************************************************************************************************

Private Function XYtoNumber(ByVal X As Long, ByVal Y As Long) As String
    Dim strXYtoNumber As String
    strXYtoNumber = Trim$(Str$(Asc(XYtoLetter(X, Y)) - Asc("a") + 1))
    If Len(strXYtoNumber) < 2 Then strXYtoNumber = "0" & strXYtoNumber
    XYtoNumber = strXYtoNumber
End Function

'***************************************************************************************************

Public Function GetAddressRegion(ByVal X As Long, ByVal Y As Long) As String
    Dim strTemp As String
    strTemp = Trim$(Str$((g_lngRgnCols - 1) - X))
    If Len(strTemp) < 2 Then strTemp = "0" & strTemp
    GetAddressRegion = strTemp & Trim$(Str$((g_lngRgnRows - 1) - Y))
End Function

'***************************************************************************************************

Public Function GetAddress250k(ByVal X As Long, ByVal Y As Long) As String
    Dim sX As Long
    Dim sY As Long
    sX = Int(X / 4)
    sY = Int(Y / 4)
    X = X - sX * 4
    Y = Y - sY * 4
    GetAddress250k = GetAddressRegion(sX, sY) & XYtoLetter(X, Y)
End Function

'***************************************************************************************************

Public Function GetAddress50k(ByVal X As Long, ByVal Y As Long) As String
    Dim RX As Long
    Dim RY As Long
    Dim sX As Long
    Dim sY As Long
    RX = Int(X / 16)
    RY = Int(Y / 16)
    X = X - RX * 16
    Y = Y - RY * 16
    sX = Int(X / 4)
    sY = Int(Y / 4)
    X = X - sX * 4
    Y = Y - sY * 4
    GetAddress50k = GetAddressRegion(RX, RY) & XYtoLetter(sX, sY) & XYtoNumber(X, Y)
End Function

'***************************************************************************************************
'END