[VBA]Compact Access Database bypassing create a dummy database

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

Function to compact Access Database bypassing create a dummy database

'Comapact and renew Database
Public Function CompactAndRenewDb(Db_path As String) As String
    On Error GoTo Err_CompactAndRenewDb
    
    Dim FailedReason As String
    
    If FileExists(Db_path) = False Then
        FailedReason = Db_path
        GoTo Exit_CompactAndRenewDb
    End If

    
    Dim WShell As Object
    Dim FSO As Object
    
    Set WShell = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")


    Dim Db_CP_path As String
    Db_CP_path = WShell.ExpandEnvironmentStrings("%TEMP%") & "\" & FSO.GetBaseName(Db_path) & "_Compacted" & "." & FSO.GetExtensionName(Db_path)

    
    If Len(Dir(Db_CP_path)) > 0 Then
        Kill Db_CP_path
    End If
    
    Call CompactDatabase(Db_path, Db_CP_path)
    
    
    If Len(Dir(Db_CP_path)) = 0 Then
        GoTo Exit_CompactAndRenewDb
    End If
    
    
    Kill Db_path
    Call CopyFileBypassErr(Db_CP_path, Db_path)
    Kill Db_CP_path
    
    
Exit_CompactAndRenewDb:
    CompactAndRenewDb = FailedReason
    Exit Function

Err_CompactAndRenewDb:
    FailedReason = Err.Description
    Resume Exit_CompactAndRenewDb
    
End Function

[VBA]Join two tables with any number of columns in a easy format

https://github.com/walter426/VbaUtilities/blob/master/SqlUtilities.bas
In order to join two tables into one, the SQL syntax is very complicated.
So I wrote below function to reduce the complexity.



''Create table which are joined from two tables
Public Function CreateTbl_JoinTwoTbl(Tbl_src_1_name As String, Tbl_src_2_name As String, JoinCond As String, ColSet_Join_1 As Variant, ColSet_Join_2 As Variant, Tbl_des_name As String, Optional ColSet_src_1 As Variant = Null, Optional ColSet_src_2 As Variant = Null, Optional ColSet_Order As Variant = Null) As String
    On Error GoTo Err_CreateTbl_JoinTwoTbl
    
    Dim FailedReason As String

    If TableExist(Tbl_src_1_name) = False Then
        FailedReason = Tbl_src_1_name & "does not exist!"
        GoTo Exit_CreateTbl_JoinTwoTbl
    End If
    
    If TableExist(Tbl_src_2_name) = False Then
        FailedReason = Tbl_src_2_name & "does not exist!"
        GoTo Exit_CreateTbl_JoinTwoTbl
    End If
    
    If IsNull(ColSet_Join_1) = True Then
        GoTo Exit_CreateTbl_JoinTwoTbl
    End If
    
    If IsNull(ColSet_Join_2) = True Then
        GoTo Exit_CreateTbl_JoinTwoTbl
    End If
    

    DelTable (Tbl_des_name)
    
    
    Dim Col_Idx As Integer
    
    
    With CurrentDb
        If IsNull(ColSet_src_1) = True Then
            Dim RS_Tbl_src As Recordset
            Set RS_Tbl_src = .OpenRecordset(Tbl_src_1_name)
            
            Dim fld_idx As Integer
            Dim fld_name As String
            
            ColSet_src_1 = Array()
            
            With RS_Tbl_src
                For fld_idx = 0 To .Fields.count - 1
                    fld_name = .Fields(fld_idx).name
                    Call AppendArray(ColSet_src_1, Array("[" & fld_name & "]"))
                Next fld_idx
                
                .Close
                
            End With 'RS_Tbl_src
        End If


        If IsNull(ColSet_src_2) = True Then
            Set RS_Tbl_src = .OpenRecordset(Tbl_src_2_name)
            
            With RS_Tbl_src
                Dim NumOfColSet_Join_found As Integer
                NumOfColSet_Join_found = 0
                
                ColSet_src_2 = Array()
                    
                For fld_idx = 0 To .Fields.count - 1
                    fld_name = .Fields(fld_idx).name

                    If NumOfColSet_Join_found <= UBound(ColSet_Join_2) And FindStrInArray(ColSet_Join_2, fld_name) > -1 Then
                        NumOfColSet_Join_found = NumOfColSet_Join_found + 1
                    Else
                        Call AppendArray(ColSet_src_2, Array("[" & fld_name & "]"))
                    End If
                Next fld_idx
    
                .Close
                
            End With 'RS_Tbl_src
        End If
    End With 'CurrentDb
    

    Dim SQL_Seg_Select As String
    SQL_Seg_Select = "SELECT " & "[" & Tbl_src_1_name & "]." & Join(ColSet_src_1, ", [" & Tbl_src_1_name & "].") & ", " & "[" & Tbl_src_2_name & "]." & Join(ColSet_src_2, ", [" & Tbl_src_2_name & "].")

    Dim SQL_Seg_JoinOn As String
    SQL_Seg_JoinOn = "("

    For Col_Idx = LBound(ColSet_Join_1) To UBound(ColSet_Join_1)
        SQL_Seg_JoinOn = SQL_Seg_JoinOn & "[" & Tbl_src_1_name & "].[" & ColSet_Join_1(Col_Idx) & "] = [" & Tbl_src_2_name & "].[" & ColSet_Join_2(Col_Idx) & "] AND "
    Next Col_Idx

    SQL_Seg_JoinOn = Left(SQL_Seg_JoinOn, Len(SQL_Seg_JoinOn) - 4) & ")"

    
    Dim SQL_Seg_OrderBy As String
    SQL_Seg_OrderBy = ""
    
    If IsNull(ColSet_Order) = False Then
        SQL_Seg_OrderBy = "ORDER BY "
        
        For Col_Idx = LBound(ColSet_Order) To UBound(ColSet_Order)
            SQL_Seg_OrderBy = SQL_Seg_OrderBy & "[" & Tbl_src_1_name & "].[" & ColSet_Order(Col_Idx) & "], "
        Next Col_Idx
        
        SQL_Seg_OrderBy = Left(SQL_Seg_OrderBy, Len(SQL_Seg_OrderBy) - 2)
        
    End If
    
    
    Dim SQL_cmd As String
    
    SQL_cmd = SQL_Seg_Select & " " & vbCrLf & _
                "INTO [" & Tbl_des_name & "] " & vbCrLf & _
                "FROM [" & Tbl_src_1_name & "] " & JoinCond & " JOIN [" & Tbl_src_2_name & "] " & vbCrLf & _
                "ON " & SQL_Seg_JoinOn & vbCrLf & _
                SQL_Seg_OrderBy & " " & vbCrLf & _
                ";"

    RunSQL_CmdWithoutWarning (SQL_cmd)


Exit_CreateTbl_JoinTwoTbl:
    CreateTbl_JoinTwoTbl = FailedReason
    Exit Function

Err_CreateTbl_JoinTwoTbl:
    FailedReason = Err.Description
    Resume Exit_CreateTbl_JoinTwoTbl
    
End Function

[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

[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

[VBA] Link Table Through Table Definition

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

As it is unable to add a link table directly by "CreateTableDef" method, so it needs to make below function to do so.

'Link Table Through Table Definition
Public Function LinkTblByTdf(Tbl_src_name As String, Tbl_des_name As String, str_conn As String) As String
    On Error GoTo Err_LinkTblByTdf
   
    Dim FailedReason As String
   
    DelTable (Tbl_des_name)
       
    With CurrentDb
        Dim tdf As TableDef
        Set tdf = .CreateTableDef(Tbl_des_name)

        tdf.Connect = str_conn
        tdf.SourceTableName = Tbl_src_name
       
        .TableDefs.Append tdf
        .TableDefs(Tbl_des_name).RefreshLink
       
    End With 'CurrentDb
       
    RefreshDatabaseWindow

Exit_LinkTblByTdf:
    LinkTblByTdf = FailedReason
    Exit Function

Err_LinkTblByTdf:
    FailedReason = Err.Description
    Resume Exit_LinkTblByTdf
   
End Function


Supplement:
My intention to write this function is to link SQLite database through ODBC.
Unfortunately, the MS Access application will be closed after it is linked to some SQLite table sometimes, with an error number, 462, which means "remote server machine not found.".
If the failure occurs, the only thing can do is to open the access application and re-link the table again.
i'm sorry that I did not find any fix or workaround to overcome this bug.

[VBA] Connect to SQLite 3 Database, and link to its table through ODBC

After many trials and study, I found out that it is impossible for a Microsoft Access Default Database Object (DBO) to connect to a SQLite database by DSN-Less or Default File DSN methods.

The only way is to create a user/system DSN to connect to a SQLite database.

Below is the details.

1. Go to below url to install the SQLite ODBC Driver,
http://www.ch-werner.de/sqliteodbc/


2. Time for trial and error,
a) Open an access file(.mdb), try to create an ODBC connection by File DSN.
After create a File DSN, then apply it to connect to a SQLite Database.
Then an error message, "Reserverd error (-7778)" will be prompted out like below,

b) Try to connect to SQLite by VBA like below,

    With CurrentDb
        Dim tdf As TableDef

        Set tdf = .CreateTableDef("SampleTable")
        tdf.Connect = "ODBC;Driver=SQLite3 ODBC Driver;Database=C:\SQLite\sample.sqlite;)
        'tdf.SourceTableName = "SampleTable"
        
        .TableDefs.Append tdf

    End With 'CurrentDb

    But it fails too.

3. Then, the only solution is to use User/System DSN.
    i) Go to "Control Panel\All Control Panel Items\Administrative Tools\Data Sources (ODBC)"
    ii) Click User/System DSN
    iii) Start to add a SQLite 3 Driver DSN till Parameter Browser, then enter a proper name (my version, SQLite3_DataSrc) necessary parameter except             database path, then save it.

4. a)Try to connect the SQLite again by the User/system DSN added in part 3) like part 2a), it should be ok.

    b) Try to connect to SQLite by VBA again like below,

    With CurrentDb
        Dim tdf As TableDef

        Set tdf = .CreateTableDef("SampleTable")
        tdf.Connect = "ODBC;DSN=SQLite3_DataSrc;Database=C:\SQLite\sample.sqlite;"
        'tdf.SourceTableName = "SampleTable"
        
        .TableDefs.Append tdf

    End With 'CurrentDb

    It works now

[VBA] Ceiling

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

Public Function Ceiling(X)
    Ceiling = Int(X) - (X - Int(X) > 0)
End Function

[VBA] Generate a concatenated string of related records (SQL Query Use)

Reference: http://allenbrowne.com/func-concat.html

https://github.com/walter426/VbaUtilities/
Useful user-defined SQL Query function to do record concatenation.

Example:
SELECT [2G_Bcch].CELL, First(ConcatRelated("bcchno"," 2G_HO_Bcch","CELL = """ & [2G_Bcch].[CELL] & """","",";")) AS BcchSet
FROM 2G_Bcch
GROUP BY [2G_Bcch].CELL;

Below is the version added a little bit of modification to suit to my vba utilities,

Code:
Public Function ConcatRelated(strField As String, _
    strTable As String, _
    Optional strWhere As String, _
    Optional strOrderBy As String, _
    Optional strSeparator = ", ") As Variant
On Error GoTo Err_ConcatRelated
    'Purpose:   Generate a concatenated string of related records.
    'Return:    String variant, or Null if no matches.
    'Arguments: strField = name of field to get results from and concatenate.
    '           strTable = name of a table or query.
    '           strWhere = WHERE clause to choose the right values.
    '           strOrderBy = ORDER BY clause, for sorting the values.
    '           strSeparator = characters to use between the concatenated values.
    'Notes:     1. Use square brackets around field/table names with spaces or odd characters.
    '           2. strField can be a Multi-valued field (A2007 and later), but strOrderBy cannot.
    '           3. Nulls are omitted, zero-length strings (ZLSs) are returned as ZLSs.
    '           4. Returning more than 255 characters to a recordset triggers this Access bug:
    '               http://allenbrowne.com/bug-16.html
    Dim rs As DAO.Recordset         'Related records
    Dim rsMV As DAO.Recordset       'Multi-valued field recordset
    Dim strSql As String            'SQL statement
    Dim strOut As String            'Output string to concatenate to.
    Dim lngLen As Long              'Length of string.
    Dim bIsMultiValue As Boolean    'Flag if strField is a multi-valued field.
    
    'Initialize to Null
    ConcatRelated = Null
    
    'Build SQL string, and get the records.
    strSql = "SELECT " & strField & " FROM " & strTable
    If strWhere <> vbNullString Then
        strSql = strSql & " WHERE " & strWhere
    End If
    If strOrderBy <> vbNullString Then
        strSql = strSql & " ORDER BY " & strOrderBy
    End If
    Set rs = DBEngine(0)(0).OpenRecordset(strSql, dbOpenDynaset)
    'Determine if the requested field is multi-valued (Type is above 100.)
    bIsMultiValue = (rs(0).Type > 100)
    
    'Loop through the matching records
    Do While Not rs.EOF
        If bIsMultiValue Then
            'For multi-valued field, loop through the values
            Set rsMV = rs(0).Value
            Do While Not rsMV.EOF
                If Not IsNull(rsMV(0)) Then
                    strOut = strOut & rsMV(0) & strSeparator
                End If
                rsMV.MoveNext
            Loop
            Set rsMV = Nothing
        ElseIf Not IsNull(rs(0)) Then
            strOut = strOut & rs(0) & strSeparator
        End If
        rs.MoveNext
    Loop
    rs.Close
    
    'Return the string without the trailing separator.
    lngLen = Len(strOut) - Len(strSeparator)
    If lngLen > 0 Then
        ConcatRelated = Left(strOut, lngLen)
    End If

Exit_ConcatRelated:
    'Clean up
    Set rsMV = Nothing
    Set rs = Nothing
    Exit Function

Err_ConcatRelated:
    Call ShowMsgBox("Error " & Err.Number & ": " & Err.Description, vbExclamation, "ConcatRelated()")
    Resume Exit_ConcatRelated
    
End Function

[VBA] Delete an Array Element

Public Sub DeleteArrayItem(arr As Variant, index As Long)
    Dim i As Long
    
    For i = index To UBound(arr) - 1
        arr(i) = arr(i + 1)
    Next
    
    ' VB will convert this to 0 or to an empty string.
    arr(UBound(arr)) = Empty
    ReDim Preserve arr(LBound(arr) To UBound(arr) - 1)
    
End Sub

[VBA] Concatenate multiple tables of identical structure

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

'Create table which is cancatenated from multiple tables of the same structure
Public Function CreateTbl_ConcatTbls(Tbl_src_Set As Variant, Tbl_des_name As String, Optional Type_Set As Variant = "") As String
    On Error GoTo Err_CreateTbl_ConcatTbls
   
    Dim FailedReason As String

    If UBound(Tbl_src_Set) < 0 Then
        FailedReason = "No table in the table set"
        GoTo Exit_CreateTbl_ConcatTbls
    End If

   
    Dim Tbl_src_name As Variant
   
    For Each Tbl_src_name In Tbl_src_Set
        If TableExist(Tbl_src_name & "") = False Then
            FailedReason = Tbl_src_name & " does not exist!"
            GoTo Exit_CreateTbl_ConcatTbls
        End If
   
    Next
   

    'Initialize Tbl_des
    DelTable (Tbl_des_name)
   
    Dim SQL_cmd As String
   
    Tbl_src_name = Tbl_src_Set(0)
   
    SQL_cmd = "SELECT " & Chr(34) & "null" & Chr(34) & " AS [Type], " & Tbl_src_name & ".* " & vbCrLf & _
                "INTO " & Tbl_des_name & " " & vbCrLf & _
                "FROM " & Tbl_src_name & " " & vbCrLf & _
                "WHERE 1 = 0 " & vbCrLf & _
                ";"
               
    RunSQL_CmdWithoutWarning (SQL_cmd)


    'Start Append
    Dim tbl_idx As Integer
    Dim SQL_Seq_Type As String
   
    For tbl_idx = 0 To UBound(Tbl_src_Set)
        Tbl_src_name = Tbl_src_Set(tbl_idx)
       
        If VarType(Type_Set) > vbArray And Type_Set(tbl_idx) = "" Then
            SQL_Seq_Type = ""
        Else
            SQL_Seq_Type = Chr(34) & Type_Set(tbl_idx) & Chr(34) & " AS [Type], "
        End If
       
        SQL_cmd = "INSERT INTO " & Tbl_des_name & " " & vbCrLf & _
                    "SELECT " & SQL_Seq_Type & "[" & Tbl_src_name & "].* " & vbCrLf & _
                    "FROM [" & Tbl_src_name & "] " & vbCrLf & _
                    ";"
       
        RunSQL_CmdWithoutWarning (SQL_cmd)
       
    Next
   
   
    If UBound(Type_Set) < 0 Then
        SQL_cmd = "ALTER TABLE [" & Tbl_des_name & "] " & vbCrLf & _
                    "DROP COLUMN [Type]" & vbCrLf & _
                    ";"

        RunSQL_CmdWithoutWarning (SQL_cmd)
       
    End If
   
   
Exit_CreateTbl_ConcatTbls:
    CreateTbl_ConcatTbls = FailedReason
    Exit Function

Err_CreateTbl_ConcatTbls:
    FailedReason = Err.Description
    Resume Exit_CreateTbl_ConcatTbls
   
End Function

[VBA] Logarithm of base 10

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

As there is not built-in function for logarithm of base 10, so it is required to build it from the default natural  Logarithm function in VBA

Public Function Log10(X)
    Log10 = Log(X) / Log(10#)
End Function

[VBA] Get Link Table connection Info

A function to obtain link table connection information such as 'link specification', current path...

'Get Link Table connection Info
Public Function GetLinkTblConnInfo(Tbl_name As String, param As String) As String
    On Error GoTo Exit_GetLinkTblConnInfo
    
    Dim LinkTblConnInfo As Variant
    LinkTblConnInfo = SplitStrIntoArray(CurrentDb.TableDefs(Tbl_name).Connect, ";")

    Dim param_idx As Integer
    Dim LinkTblConnParam As String
    
    param = param & "="

    For param_idx = 0 To UBound(LinkTblConnInfo)
        LinkTblConnParam = LinkTblConnInfo(param_idx)

        If Left(LinkTblConnParam, Len(param)) = param Then
            GetLinkTblConnInfo = Right(LinkTblConnParam, Len(LinkTblConnParam) - Len(param))
            Exit For
        End If
    Next param_idx
    
    
Exit_GetLinkTblConnInfo:
    Exit Function

Err_GetLinkTblConnInfo:
    ShowMsgBox (Err.Description)
    GetLinkTblConnInfo = ""
    Resume Exit_GetLinkTblConnInfo
    
End Function

[VBA] Get the current path of a link table

'Get the current path of a link table
Public Function GetLinkTblPath(Tbl_name As String) As String
    On Error GoTo Exit_GetLinkTblPath
    
    Dim LinkTblPath As String
    
    LinkTblPath = CurrentDb.TableDefs(Tbl_name).Connect
    LinkTblPath = Right(LinkTblPath, Len(LinkTblPath) - (InStr(1, LinkTblPath, "DATABASE=") + 8)) & "\" & CurrentDb.TableDefs(Tbl_name).SourceTableName
    
    GetLinkTblPath = LinkTblPath
    
Exit_GetLinkTblPath:
    Exit Function

Err_GetLinkTblPath:
    ShowMsgBox (Err.Description)
    GetLinkTblPath = ""
    Resume Exit_GetLinkTblPath
    
End Function

[VBA] Send shell commands keeping alive to Unix via Telnet

Below is an example to make use of my function, Shell_SendKeysWithTimeout to send shell command to remote Unix server via telnet, and keep the command running even after disconnection(nohup).

Code:

    Dim FailedReason As String
    
    Dim oShell As Object
    Set oShell = CreateObject("WScript.Shell")

    Dim CmdTxt As String
    
    CmdTxt = "telnet " & IP & vbCrLf & _
                  user & vbCrLf & _
                  pw & vbCrLf & _
                "nohup sample_script " & vbCrLf & _
                ""
    
    oShell.Run ("cmd.exe")
    Sleep 1000
    
    FailedReason = Shell_SendKeysWithTimeout(oShell, CmdTxt, 1000)

[VBA] Split a Text File into multiple text files of specified row count

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

The intention to write this function is to split a text files of row count more than 65535 into multiple text files,
so that it is able to modify those files further by Excel which has limit of 65536 rows on reading any files.
Therefore, This function has the option to add header rows from the original files.


'Split a Text File into multiple text files of specified row count(default: 65535)
Public Function SplitTextFile(src As String, Optional des_fmt As String, Optional RowCntPerFile As Long = 65535, Optional file_idx_start As Integer = 0, Optional NumOfHdrRows As Long = 0, Optional DeleteSrc As Boolean = False) As String
    On Error GoTo Err_SplitTextFile
    
    Dim FailedReason As String


    If Len(Dir(src)) = 0 Then
        FailedReason = src
        GoTo Exit_SplitTextFile
    End If

    If RowCntPerFile < NumOfHdrRows + 1 Then
        FailedReason = "RowCntPerFile < NumOfHdrRows + 1"
        GoTo Exit_SplitTextFile
    End If


    'if no need to split, return
    Dim RowCnt_src As Long
    RowCnt_src = CountRowsInText(src)
    
    If RowCnt_src <= RowCntPerFile Then
        GoTo Exit_SplitTextFile
    End If
    
    
    'Check whether there exists files which name is same to the splitted files
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim des_dir As String
    Dim des_name As String
    Dim des_ext As String
    Dim des_path As String
    
    des_dir = fso.GetParentFolderName(src)
    des_name = fso.GetFileName(src)
    des_ext = fso.GetExtensionName(src)

    If des_fmt = "" Then
        des_fmt = Left(des_name, Len(des_name) - Len("." & des_ext)) & "_*"
    End If

    
    Dim NumOfSplit As Integer
    
    If RowCnt_src <= RowCntPerFile Then
        NumOfSplit = 0
    Else
        NumOfSplit = Int((RowCnt_src - RowCntPerFile) / (RowCntPerFile + 1 - NumOfHdrRows)) + 1
    End If
    
    
    Dim file_idx_end As Integer
    file_idx_end = file_idx_start + NumOfSplit 'Int(RowCnt_src / (RowCntPerFile + 1 - NumOfHdrRows))
    
    
    Dim file_idx As Integer
    
    For file_idx = file_idx_start To file_idx_end
        des_path = des_dir & "\" & Replace(des_fmt, "*", str(file_idx)) & "." & des_ext
        
        If Len(Dir(des_path)) > 0 Then
            Exit For
        End If
        
    Next file_idx
    
    
    If Len(Dir(des_path)) > 0 Then
        FailedReason = des_path
        GoTo Exit_SplitTextFile
    End If
    
    
    
    'Obtain header rows for later files and create the first splitted file
    Dim File_src As Object
    Dim FileNum_des As Integer
    Dim str_line As String
    Dim HdrRows As String

    Set File_src = fso.OpenTextFile(src, 1)
    des_path = des_dir & "\" & Replace(des_fmt, "*", str(file_idx_start)) & "." & des_ext
    FileNum_des = FreeFile
    Open des_path For Output As #FileNum_des
    
    RowCnt = 0
    
    Do Until RowCnt >= NumOfHdrRows Or File_src.AtEndOfStream = True
        RowCnt = RowCnt + 1
        str_line = File_src.ReadLine
        Print #FileNum_des, str_line
        HdrRows = HdrRows & str_line
        
    Loop

    
    Do Until RowCnt >= RowCntPerFile Or File_src.AtEndOfStream = True
        RowCnt = RowCnt + 1
        Print #FileNum_des, File_src.ReadLine
        
    Loop
    
    Close #FileNum_des
    

    'Start to split
    For file_idx = file_idx_start + 1 To file_idx_end
        If File_src.AtEndOfStream = True Then
            Exit For
        End If
            
        des_path = des_dir & "\" & Replace(des_fmt, "*", str(file_idx)) & "." & des_ext
        FileNum_des = FreeFile
        Open des_path For Output As #FileNum_des

        RowCnt = NumOfHdrRows
        Print #FileNum_des, HdrRows

        Do Until RowCnt >= RowCntPerFile Or File_src.AtEndOfStream = True
            RowCnt = RowCnt + 1
            Print #FileNum_des, File_src.ReadLine
            
        Loop

        Close #FileNum_des
        
    Next file_idx

    
    File_src.Close


    If DeleteSrc = True Then
        Kill src
    End If
    
    
Exit_SplitTextFile:
    SplitTextFile = FailedReason
    Exit Function

Err_SplitTextFile:
    FailedReason = Err.Description
    Resume Exit_SplitTextFile
    
End Function

[VBA] Count Row Number of a text file

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

Public Function CountRowsInText(file_name As String) As Long
    On Error GoTo Err_CountRowsInText
    
    Dim fso As Object
    Dim File As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set File = fso.OpenTextFile(file_name, 1)


    Dim RowCnt As Long
    Dim str_line As String
    
    RowCnt = 0

    Do Until File.AtEndOfStream = True
        RowCnt = RowCnt + 1
        str_line = File.ReadLine
        
    Loop


    File.Close


Exit_CountRowsInText:
    CountRowsInText = RowCnt
    Exit Function

Err_CountRowsInText:
    RowCnt = -1
    Call ShowMsgBox(Err.Description)
    Resume Exit_CountRowsInText

End Function