[VBA] Coordinate Transform between Grid and Geographic (e.g HK1980 and WGS84)

https://github.com/walter426/VbaUtilities/blob/master/GeometryUtilities.bas

Below is the function set to perform the coordinate transform between Grid and Geographic, the pair of HK1980 and WGS84 is taken as the example for this kind of transform

'Coordinate Transformation according to http://www.geodetic.gov.hk/data/pdf/explanatorynotes_c.pdf

Public Const Pi = 3.14159265359

'Coordinate Transform from HK1980 grid to WGS84 geographic in degree
Public Function CoorTransform_Hk1980ToWgs84(Easting, Northing, Optional Delimiter As String = "") As Variant
    'Initilalize Constant
    E0 = 836694.05
    N0 = 819069.8
    Lng0 = 114.178556
    Lat0 = 22.312133
    m_0 = 1
    M0 = 2468395.723
    a = 6378388
    e2 = 6.722670022 * (10 ^ (-3))
    
    LngLat_HK1980 = CoorTransform_GridToGeographic(E0, N0, Lng0, Lat0, m_0, M0, a, e2, Easting, Northing)

    Lng_WGS84 = LngLat_HK1980(0) + (8.8 / 3600)
    Lat_WGS84 = LngLat_HK1980(1) - (5.5 / 3600)
    
    
    If Delimiter = "" Then
        CoorTransform_Hk1980ToWgs84 = Array(Lng_WGS84, Lat_WGS84)
    Else
        CoorTransform_Hk1980ToWgs84 = Lng_WGS84 & Delimiter & Lat_WGS84
    End If
    
    
End Function



Public Function CoorTransform_GridToGeographic(E0, N0, Lng0, Lat0, m_0, M0, a, e2, Easting, Northing, Optional accuracy = 6) As Variant
    'Meridian distance Coefficients
    A0 = 1 - (e2 / 4) - (3 * (e2 ^ 2) / 64)
    A2 = (3 / 8) * (e2 + ((e2 ^ 2) / 4))
    A4 = (15 / 256) * (e2 ^ 2)
    

    'Convert the Lat0 and Lng0 from degree to radian
    Lng0 = Lng0 * Pi / 180
    Lat0 = Lat0 * Pi / 180
    
    
    'Convert from grid to geographic
    'Calculate Lat_p by iteration of Meridian distance,
    E_Delta = Easting - E0
    N_delta = Northing - N0
    Mp = (N_delta + M0) / m_0
    
    Lat_min = -90 * Pi / 180
    Lat_max = 90 * Pi / 180

    accuracy = 10 ^ (-accuracy)
    

     'Newton 's method
    Lat_p = (Lat_max + Lat_min) / 2
    f = 1.1
    
    Do While Abs(f) > accuracy
        f = Mp - a * (A0 * Lat_p - A2 * Sin(2 * Lat_p) + A4 * Sin(4 * Lat_p))
        f_d1 = -a * (A0 - A2 * 2 * Cos(2 * Lat_p) + A4 * 4 * Cos(4 * Lat_p))
        Lat_p = Lat_p - (f / f_d1)

    Loop
    
    
    t_p = Tan(Lat_p)
    v_p = a / ((1 - e2 * Sin(Lat_p) ^ 2) ^ (1 / 2))
    p_p = (a * (1 - e2)) / ((1 - e2 * Sin(Lat_p) ^ 2) ^ (3 / 2))
    W_p = v_p / p_p
    

    Lng = Lng0 + (1 / Cos(Lat_p)) * ((E_Delta / (m_0 * v_p)) - (1 / 6) * ((E_Delta / (m_0 * v_p)) ^ 3) * (W_p + 2 * (t_p ^ 2)))
    Lat = Lat_p - (t_p / ((m_0 * p_p))) * ((E_Delta ^ 2) / ((2 * m_0 * v_p)))


    CoorTransform_GridToGeographic = Array(Lng / Pi * 180, Lat / Pi * 180)
    
    
End Function



Public Function CoorTransform_Wgs84ToHK1980(Lng, Lat, Optional Delimiter As String = "") As Variant
    'Initilalize Constant
    E0 = 836694.05
    N0 = 819069.8
    Lng0 = 114.178556
    Lat0 = 22.312133
    m_0 = 1
    M0 = 2468395.723
    a = 6378388
    e2 = 6.722670022 * (10 ^ (-3))
    
    Lng_HK1980 = Lng - (8.8 / 3600)
    Lat_HK1980 = Lat + (5.5 / 3600)
    
    EastNorth_HK1980 = CoorTransform_GeographicToGrid(E0, N0, Lng0, Lat0, m_0, M0, a, e2, Lng_HK1980, Lat_HK1980)
    
    
    If Delimiter = "" Then
        CoorTransform_Wgs84ToHK1980 = EastNorth_HK1980
    Else
        CoorTransform_Wgs84ToHK1980 = EastNorth_HK1980(0) & Delimiter & EastNorth_HK1980(1)
    End If
    
    
End Function


'Coordinate Transform from geographic in degree to grid
Public Function CoorTransform_GeographicToGrid(E0, N0, Lng0, Lat0, m_0, M0, a, e2, Lng, Lat) As Variant
    'Meridian distance Coefficients
    A0 = 1 - (e2 / 4) - (3 * (e2 ^ 2) / 64)
    A2 = (3 / 8) * (e2 + ((e2 ^ 2) / 4))
    A4 = (15 / 256) * (e2 ^ 2)
    

    'Convert Lat and Lng from degree to radian
    Lng0 = Lng0 * Pi / 180
    Lat0 = Lat0 * Pi / 180
    
    Lng = Lng * Pi / 180
    Lat = Lat * Pi / 180
    
    
    'Convert from geographic to grid
    Lng_Delta = Lng - Lng0
    M = a * (A0 * Lat - A2 * Sin(2 * Lat) + A4 * Sin(4 * Lat))

    t_s = Tan(Lat)
    v_s = a / ((1 - e2 * Sin(Lat) ^ 2) ^ (1 / 2))
    p_s = (a * (1 - e2)) / ((1 - e2 * Sin(Lat) ^ 2) ^ (3 / 2))
    W_s = v_s / p_s
    

    Easting = E0 + m_0 * v_s * (Lng_Delta * Cos(Lat) + (1 / 6) * (Lng_Delta ^ 3) * (Cos(Lat) ^ 3) * (W_s - t_s ^ 2))
    Northing = N0 + m_0 * ((M - M0) + v_s * ((Lng_Delta ^ 2) / 4) * Sin(2 * Lat))


    CoorTransform_GeographicToGrid = Array(Easting, Northing)
    
    
End Function

[VBA] Append Access SQL Object(Table, Query) to Excel worksheet

Code:

'Append Access SQL Object(Table, Query) to Excel worksheet, and activate it 
Public Function AppendSqlObjToAndActivateWs(oWs As Worksheet, SqlObj_name As String, Optional AddBorder As Boolean = False) As String
    On Error GoTo Err_AppendSqlObjToAndActivateWs
    
    Dim FailedReason As String

    If TableExist(SqlObj_name) = False And QueryExist(SqlObj_name) Then
        FailedReason = SqlObj_name & " does not exist!"
        GoTo Exit_AppendSqlObjToAndActivateWs
    End If
    
    With oWs
        'Have to activate the worksheet for copying query with no error!
        .Activate
        
        'Store the new start row
        Dim RowEnd_old As Long
        Dim RowStart_new As Long
        
        RowEnd_old = .UsedRange.Rows.count
        RowStart_new = RowEnd_old + 1
        
        'Append SqlObj_name to the sheet
        
        'Create Recordset object
        Dim rs As DAO.Recordset
        Set rs = CurrentDb.OpenRecordset(SqlObj_name, dbOpenSnapshot)

        .Range("A" & CStr(.UsedRange.Rows.count + 1)).CopyFromRecordset rs, 65534


        'Copy format from previous rows to new rows
        .Range(.Cells(RowEnd_old, 1), .Cells(RowEnd_old, .UsedRange.Columns.count)).Copy
        .Range(.Cells(RowStart_new, 1), .Cells(.UsedRange.Rows.count, .UsedRange.Columns.count)).PasteSpecial Paste:=xlPasteFormats
        

        If AddBorder = True Then
            'Add border at the last row
            With .UsedRange.Rows(.UsedRange.Rows.count).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With '.UsedRange.Rows(.UsedRange.Rows.count).Borders(xlEdgeBottom)
        End If
        
        
    End With 'oWs
    
    
Exit_AppendSqlObjToAndActivateWs:
    AppendSqlObjToAndActivateWs = FailedReason
    Exit Function

Err_AppendSqlObjToAndActivateWs:
    FailedReason = Err.Description
    Resume Exit_AppendSqlObjToAndActivateWs
    
End Function

[VBA] Create an expression that consists of a set of vector columns aggregated in a specified pattern

https://github.com/walter426/VbaUtilities

Sometimes, it is needed to create an SQL expression that aggregate a set of columns in the same groups.
(e.g. 1*abc_1 + 2*abc_2 + 3*abc_3 + ...)
It will be very troublesome to aggregate them one by one by hand typing.

'To create an expression that consists of a set of vector columns aggregated in a specified pattern
Public Function CreateSqlSeg_VectorColAgg(col_pattern As String, str_agg As String, Idx_start As Integer, Idx_end As Integer, Optional wildcard As String = "#") As String
    On Error GoTo Err_CreateSqlSeg_VectorColAgg
    
    Dim SQL_Seg As String
    Dim col_idx As Integer
    
    For col_idx = Idx_start To Idx_end
        SQL_Seg = SQL_Seg & Replace(col_pattern, wildcard, col_idx) & " " & str_agg & " "
    Next col_idx
    
    SQL_Seg = Left(SQL_Seg, Len(SQL_Seg) - 2)
    
    
Exit_CreateSqlSeg_VectorColAgg:
    CreateSqlSeg_VectorColAgg = SQL_Seg
    Exit Function

Err_CreateSqlSeg_VectorColAgg:
    ShowMsgBox (Err.Description)
    Resume Exit_CreateSqlSeg_VectorColAgg
    
End Function

[VBA] Cautions of processing very large volume of data in MS ACCESS 2003

In MS ACCESS 2003 of before version, there is about 2GB maximum limit in the size of the MDB file.
It is very suck that the MDB will corrupt when VBA is running so that the size of the MDB increase over the 2GB limit. The VBE of the corrupted MDB cannot be opened in anyway, so that any VB code or modules are not able to be exported outside for recovery. Therefore, pls notice below cautions.

1. Always make a copy of your newest MDB.

2. Always create large tables outside the working MDB, below is an example using my VbaUtilities.
    Dim Db_Sample_path As String
    Db_Sample_path = "./Sample.mdb"
    
    DelTable ("Sample")
    DoCmd.TransferDatabase acLink, "Microsoft Access", Db_Sample_path, acTable, "Sample", "Sample", True
    
    
    Dim Db_Sample_l_path As String
    Db_Sample_l_path = CurrentProject.Path & "\" & "Sample_local.mdb"

    Kill Db_Sample_l_path
    Call DBEngine.CreateDatabase(Db_Sample_l_path, dbLangGeneral)
    
    Dim SQL_cmd As String

    SQL_cmd = "SELECT * " & vbCrLf & _
                "INTO [MS Access;DATABASE=" & Db_Sample_l_path & ";].[Sample_local]" & vbCrLf & _
                "FROM [Sample]" & vbCrLf & _
                ";"

    RunSQL_CmdWithoutWarning (SQL_cmd)
    
    
    DelTable ("Sample_local")
    DoCmd.TransferDatabase acLink, "Microsoft Access", Db_Sample_l_path, acTable, "Sample_local", "Sample_local", True

[Python] Google Maps Web Services

https://github.com/walter426/Python_GoogleMapsApi
https://pypi.python.org/pypi/GoogleMapsApi

A trial module to provide Google Maps Web Service for python.
Currenty, only geocoding, elevation and directions services are available now.

[VBA] Append table from MS ACCESS to SQLite

https://github.com/walter426/VbaUtilities/blob/master/SqlUtilities.bas

Due to the limitation of the ODBC connection, it is impossible to insert or update all records from access table into the SQLite table in one time. We need to do it in an indirect way like below,
1. Copy the table with data to be appended into a temporary .mdb database
2. Convert the mdb file to SQLite formet.(Java)
http://waltertech426.blogspot.com/2014/01/sqlite-convert-ms-access-mdb-file-into.html
3. Do the appending through SQLite script directly.(Python)
https://github.com/walter426/VbaUtilities/blob/master/SQLiteCmdParser.py

As below function required other functions I have written before, pls refer below repository
https://github.com/walter426/VbaUtilities/



'Execute SQLite Command Set
Public Function ExecuteSQLiteCmdSet(SQLiteDb_path As String, CmdSet As String) As String
    On Error GoTo Err_ExecuteSQLiteCmdSet
    
    Dim FailedReason As String

    If FileExists(SQLiteDb_path) = False Then
        FailedReason = SQLiteDb_path
        GoTo Exit_ExecuteSQLiteCmdSet
    End If
    
    
    'Create a SQLite Command file, and then parse it into the Python SQLite Command Parser for execution
    Dim SQLiteCmdFile_path As String
    Dim iFileNum_SQLiteCmd As Integer
    
    SQLiteCmdFile_path = [CurrentProject].[Path] & "\" & "SQLiteCmd.txt"
    iFileNum_SQLiteCmd = FreeFile()
    
    If FileExists(SQLiteCmdFile_path) = True Then
        Kill SQLiteCmdFile_path
    End If
    
    Open SQLiteCmdFile_path For Output As iFileNum_SQLiteCmd
    Print #iFileNum_SQLiteCmd, CmdSet
    Close #iFileNum_SQLiteCmd
    
    ShellCmd = "python " & [CurrentProject].[Path] & "\SQLiteCmdParser.py " & SQLiteDb_path & " " & SQLiteCmdFile_path
    Call ShellAndWait(ShellCmd, vbHide)

    Kill SQLiteCmdFile_path


Exit_ExecuteSQLiteCmdSet:
    ExecuteSQLiteCmdSet = FailedReason
    Exit Function

Err_ExecuteSQLiteCmdSet:
    Call ShowMsgBox(Err.Description)
    Resume Exit_ExecuteSQLiteCmdSet
    
End Function


'Append Table into a SQLite database
Public Function AppendTblToSQLite(Tbl_src_name As String, Tbl_des_name As String) As String
    On Error GoTo Err_AppendTblToSQLite
    
    Dim FailedReason As String
    
    If TableExist(Tbl_src_name) = False Then
        FailedReason = Tbl_src_name
        GoTo Exit_AppendTblToSQLite
    End If
    
    If TableExist(Tbl_des_name) = False Then
        FailedReason = Tbl_des_name
        GoTo Exit_AppendTblToSQLite
    End If
    
    
    'Create Db
    Dim TempDb_path As String
    TempDb_path = [CurrentProject].[Path] & "\TempDb.mdb"
    
    If FileExists(TempDb_path) = True Then
        Kill TempDb_path
    End If
    
    Call CreateDatabase(TempDb_path, dbLangGeneral)

    
    'Copy Table into the TempDb
    Dim SQL_cmd As String
    
    SQL_cmd = "SELECT * " & vbCrLf & _
                "INTO [" & Tbl_des_name & "]" & vbCrLf & _
                "IN '" & TempDb_path & "'" & vbCrLf & _
                "FROM [" & Tbl_src_name & "] " & vbCrLf & _
                ";"
    
    RunSQL_CmdWithoutWarning (SQL_cmd)


    'Convert TempDb into SQLite
    Dim SQLiteDb_path As String
    SQLiteDb_path = [CurrentProject].[Path] & "\TempDb.sqlite"
    
    If FileExists(SQLiteDb_path) = True Then
        Kill SQLiteDb_path
    End If
    
    Dim ShellCmd As String
    ShellCmd = "java -jar " & [CurrentProject].[Path] & "\mdb-sqlite.jar " & TempDb_path & " " & SQLiteDb_path
    Call ShellAndWait(ShellCmd, vbHide)
    
    SQL_cmd = "ATTACH """ & SQLiteDb_path & """ AS TempDb;" & vbCrLf & _
                "INSERT INTO [" & Tbl_des_name & "] SELECT * FROM TempDb.[" & Tbl_des_name & "];"
    
    Call ExecuteSQLiteCmdSet(GetLinkTblConnInfo(Tbl_des_name, "DATABASE"), SQL_cmd)
    
    Kill SQLiteDb_path
    Kill TempDb_path


Exit_AppendTblToSQLite:
    AppendTblToSQLite = FailedReason
    Exit Function

Err_AppendTblToSQLite:
    Call ShowMsgBox(Err.Description)
    Resume Exit_AppendTblToSQLite
    
End Function

[VBA] Remove all link tables

https://github.com/walter426/VbaUtilities/blob/master/AccessObjUtilities.bas

All .mdb and ODBC link tables will be deleted by below function

'Remove all link tables
Public Function RemoveLink() As String
    On Error GoTo Err_RemoveLink
    
    Dim FailedReason As String
    
    Dim tdf As TableDef

    For Each tdf In CurrentDb.TableDefs
        If tdf.Attributes = dbAttachedTable Or tdf.Attributes = dbAttachedODBC Then
            DoCmd.DeleteObject acTable, tdf.Name
        End If
    Next tdf

Exit_RemoveLink:
    RemoveLink = FailedReason
    Exit Function

Err_RemoveLink:
    FailedReason = Err.Description
    Resume Exit_RemoveLink
    
End Function