openaccess/source/modules/VCS_Table.bas

Option Compare Database

Option Private Module
Option Explicit

' --------------------------------
' Structures
' --------------------------------

' Structure to keep track of "on Update" and "on Delete" clauses
' Access does not in all cases execute such queries
Private Type structEnforce
    foreignTable As String
    foreignFields() As String
    table As String
    refFields() As String
    isUpdate As Boolean
End Type

' keeping "on Update" relations to be complemented after table creation
Private k() As structEnforce


Public Sub ExportLinkedTable(ByVal tbl_name As String, ByVal dirpath As String)
    On Error GoTo Err_LinkedTable
    
    Dim tempFilePath As String

    tempFilePath = VCS_File.TempFile()
    
    Dim FSO As Object
    Dim OutFile As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    ' open file for writing with Create=True, Unicode=True (USC-2 Little Endian format)

    Set OutFile = FSO.CreateTextFile(tempFilePath, overwrite:=True, unicode:=True)
    
    OutFile.Write CurrentDb.TableDefs(tbl_name).name
    OutFile.Write vbCrLf
    
    If InStr(1, CurrentDb.TableDefs(tbl_name).connect, "DATABASE=" & CurrentProject.path) Then
        'change to relatave path
        Dim connect() As String
        connect = Split(CurrentDb.TableDefs(tbl_name).connect, CurrentProject.path)
        OutFile.Write connect(0) & "." & connect(1)
    Else
        OutFile.Write CurrentDb.TableDefs(tbl_name).connect
    End If
    
    OutFile.Write vbCrLf
    OutFile.Write CurrentDb.TableDefs(tbl_name).SourceTableName
    OutFile.Write vbCrLf
    
    Dim db As DAO.Database
    Set db = CurrentDb
    Dim td As DAO.TableDef
    Set td = db.TableDefs(tbl_name)
    Dim idx As DAO.index
    
    For Each idx In td.Indexes
        If idx.Primary Then
            OutFile.Write Right$(idx.Fields, Len(idx.Fields) - 1)
            OutFile.Write vbCrLf
        End If

    Next
    
Err_LinkedTable_Fin:
    On Error Resume Next
    OutFile.Close
    'save files as .odbc
    Dim path As String
    path = dirpath & to_filename(tbl_name) & ".LNKD"
    VCS_File.ConvertUcs2Utf8 tempFilePath, path
    
    Kill tempFilePath
    
    logger "ExportLinkedTable", "DEBUG", "LinkedTable " & tbl_name & " exported to " & path
    
    Exit Sub
    
Err_LinkedTable:
    OutFile.Close
    logger "ExportLinkedTable", "ERROR", "Unable to export " & tbl_name & ": " & err.Description
    Resume Err_LinkedTable_Fin
End Sub

' This requires Microsoft ADO Ext. 2.x for DLL and Security
' See reference: https://social.msdn.microsoft.com/Forums/office/en-US/883087ba-2c25-4571-bd3c-706061466a11/how-can-i-programmatically-access-scale-property-of-a-decimal-data-type-field?forum=accessdev
Private Function formatDecimal(ByVal tableName As String, ByVal fieldName As String) As String

    Dim cnn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim col As ADOX.Column
    
    Set cnn = New ADODB.Connection
    Set cat = New ADOX.Catalog
    

    Set cnn = CurrentProject.Connection
    Set cat.ActiveConnection = cnn

    Set col = cat.Tables(tableName).Columns(fieldName)

    formatDecimal = "(" & col.Precision & ", " & col.NumericScale & ")"

    Set col = Nothing
    Set cat = Nothing
    Set cnn = Nothing

End Function

' Save a Table Definition as SQL statement
Public Sub ExportTableDef(ByRef db As DAO.Database, ByRef td As DAO.TableDef, ByVal directory As String)
    Dim tableName, filename As String
    
    tableName = td.name
    filename = directory & to_filename(tableName) & ".sql"
    
    Dim sql As String
    Dim fieldAttributeSql As String
    Dim idx As DAO.index
    Dim fi As DAO.Field
    Dim FSO As Object
    Dim OutFile As Object
    Dim ff As Object
    
    'Debug.Print tableName
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set OutFile = FSO.CreateTextFile(filename, overwrite:=True, unicode:=False)
    
    sql = "CREATE TABLE " & strName(tableName) & " (" & vbCrLf
    
    For Each fi In td.Fields
        sql = sql & "  " & strName(fi.name) & " "
        If (fi.Attributes And dbAutoIncrField) Then
            sql = sql & "AUTOINCREMENT"
        Else
            sql = sql & strType(fi.Type) & " "
        End If
        Select Case fi.Type
            Case dbText, dbVarBinary
                sql = sql & "(" & fi.Size & ")"
            Case dbDecimal
                sql = sql & formatDecimal(tableName, fi.name)
            Case Else
        End Select
        For Each idx In td.Indexes
            fieldAttributeSql = vbNullString
            If idx.Fields.count = 1 And idx.Fields(0).name = fi.name Then
                If idx.Primary Then fieldAttributeSql = fieldAttributeSql & " PRIMARY KEY "
                If idx.Unique Then fieldAttributeSql = fieldAttributeSql & " UNIQUE "
                If idx.Required Then fieldAttributeSql = fieldAttributeSql & " NOT NULL "
                If idx.Foreign Then
                    Set ff = idx.Fields
                    fieldAttributeSql = fieldAttributeSql & formatReferences(db, ff, tableName)
                End If
                If Len(fieldAttributeSql) > 0 Then fieldAttributeSql = " CONSTRAINT " & strName(idx.name) & fieldAttributeSql
            End If
            sql = sql & fieldAttributeSql
        Next
        sql = sql & "," & vbCrLf
    Next
    sql = Left$(sql, Len(sql) - 3) ' strip off last comma and crlf
    
    Dim constraintSql As String
    For Each idx In td.Indexes
        If idx.Fields.count > 1 Then
            If Len(constraintSql) = 0 Then constraintSql = constraintSql & " CONSTRAINT "
            If idx.Primary Then constraintSql = constraintSql & formatConstraint("PRIMARY KEY", idx)
            If Not idx.Foreign Then
                If Len(constraintSql) > 0 Then
                    sql = sql & "," & vbCrLf & "  " & constraintSql
                    sql = sql & formatReferences(db, idx.Fields, tableName)
                End If
            End If
        End If
    Next
    sql = sql & vbCrLf & ")"

    'Debug.Print sql
    OutFile.WriteLine sql
    
    OutFile.Close
    
    'exort Data Macros
    VCS_DataMacro.ExportDataMacros tableName, directory
    
    logger "ExportTableDef", "DEBUG", "TblDef '" & tableName & "' exported to " & filename
    
End Sub

Private Function formatReferences(db As DAO.Database, ff As Object, _
                                  ByVal tableName As String) As String

    Dim rel As DAO.Relation
    Dim sql As String
    Dim f As DAO.Field
    
    For Each rel In db.Relations
        If (rel.foreignTable = tableName) Then
         If FieldsIdentical(ff, rel.Fields) Then
          sql = " REFERENCES "
          sql = sql & strName(rel.table) & " ("
          For Each f In rel.Fields
            sql = sql & strName(f.name) & ","
          Next
          sql = Left$(sql, Len(sql) - 1) & ")"
          If rel.Attributes And dbRelationUpdateCascade Then
            sql = sql + " ON UPDATE CASCADE "
          End If
          If rel.Attributes And dbRelationDeleteCascade Then
            sql = sql + " ON DELETE CASCADE "
          End If
          Exit For
         End If
        End If
    Next
    
    formatReferences = sql
End Function

Private Function formatConstraint(ByVal keyw As String, ByVal idx As DAO.index) As String
    Dim sql As String
    Dim fi As DAO.Field
    
    sql = strName(idx.name) & " " & keyw & " ("
    For Each fi In idx.Fields
        sql = sql & strName(fi.name) & ", "
    Next
    sql = Left$(sql, Len(sql) - 2) & ")" 'strip off last comma and close brackets
    
    'return value
    formatConstraint = sql
End Function

Private Function strName(ByVal S As String) As String
    strName = "[" & S & "]"
End Function

Private Function strType(ByVal i As Integer) As String
    Select Case i
    Case dbLongBinary
        strType = "LONGBINARY"
    Case dbBinary
        strType = "BINARY"
    Case dbBoolean
        strType = "BIT"
    Case dbAutoIncrField
        strType = "COUNTER"
    Case dbCurrency
        strType = "CURRENCY"
    Case dbDate, dbTime
        strType = "DATETIME"
    Case dbGUID
        strType = "GUID"
    Case dbMemo
        strType = "LONGTEXT"
    Case dbDouble
        strType = "DOUBLE"
    Case dbSingle
        strType = "SINGLE"
    Case dbByte
        strType = "BYTE"
    Case dbInteger
        strType = "SHORT"
    Case dbLong
        strType = "LONG"
    Case dbNumeric
        strType = "NUMERIC"
    Case dbText
        strType = "VARCHAR"
    Case dbDecimal
        strType = "DECIMAL"
    Case Else
        strType = "VARCHAR"
    End Select
End Function

Private Function FieldsIdentical(ff As Object, gg As Object) As Boolean
    Dim f As DAO.Field
    If ff.count <> gg.count Then
        FieldsIdentical = False
        Exit Function
    End If
    For Each f In ff
        If Not FieldInFields(f, gg) Then
        FieldsIdentical = False
        Exit Function
        End If
    Next
    
    FieldsIdentical = True
End Function

Private Function FieldInFields(fi As DAO.Field, ff As DAO.Fields) As Boolean
    Dim f As DAO.Field
    For Each f In ff
        If f.name = fi.name Then
            FieldInFields = True
            Exit Function
        End If
    Next
    
    FieldInFields = False
End Function

' Determine if a table or exists.
' based on sample code of support.microsoftcom
' ARGUMENTS:
'    TName: The name of a table or query.
'
' RETURNS: True (it exists) or False (it does not exist).
Private Function TableExists(ByVal TName As String) As Boolean
    Dim db As DAO.Database
    Dim Found As Boolean
    Dim test As String
    
    Const NAME_NOT_IN_COLLECTION As Integer = 3265
    
     ' Assume the table or query does not exist.
    Found = False
    Set db = CurrentDb()
    
     ' Trap for any errors.
    On Error Resume Next
     
     ' See if the name is in the Tables collection.
    test = db.TableDefs(TName).name
    If err.Number <> NAME_NOT_IN_COLLECTION Then Found = True
    
    ' Reset the error variable.
    err = 0
    
    TableExists = Found
End Function

' Build SQL to export `tbl_name` sorted by each field from first to last
Private Function TableExportSql(ByVal tbl_name As String) As String
    Dim rs As Object ' DAO.Recordset
    Dim fieldObj As Object ' DAO.Field
    Dim sb() As String, count As Integer

    Set rs = CurrentDb.OpenRecordset(tbl_name)
    
    sb = VCS_String.Sb_Init()
    VCS_String.Sb_Append sb, "SELECT "
    
    count = 0
    For Each fieldObj In rs.Fields
        If count > 0 Then VCS_String.Sb_Append sb, ", "
        VCS_String.Sb_Append sb, "[" & fieldObj.name & "]"
        count = count + 1
    Next
    
    VCS_String.Sb_Append sb, " FROM [" & tbl_name & "] ORDER BY "
    
    count = 0
    For Each fieldObj In rs.Fields
        DoEvents
        If fieldObj.Type <> 109 And _
           fieldObj.Type <> 101 And _
           fieldObj.Type <> 11 Then   'ignore muliple choices fields, ole, and attached fields
           
            If count > 0 Then VCS_String.Sb_Append sb, ", "
            VCS_String.Sb_Append sb, "[" & fieldObj.name & "]"
            count = count + 1
        End If
    Next

    TableExportSql = VCS_String.Sb_Get(sb)
End Function

' Export the lookup table `tblName` to `source\tables`.
Public Sub ExportTableData(ByVal tbl_name As String, ByVal obj_path As String)
On Error GoTo err
    Dim FSO As Object
    Dim OutFile As Object
    Dim rs As DAO.Recordset ' DAO.Recordset
    Dim fieldObj As Object ' DAO.Field
    Dim c As Long, value As Variant
    
    ' Checks first
    If Not TableExists(tbl_name) Then
        logger "ExportTableData", "ERROR", "Table " & tbl_name & " missing"
        Exit Sub
    End If

    Set rs = CurrentDb.OpenRecordset(TableExportSql(tbl_name))
    If rs.RecordCount = 0 Then
        'why is this an error? Debug.Print "Error: Table " & tbl_name & "  empty"
        rs.Close
        Exit Sub
    End If

    Set FSO = CreateObject("Scripting.FileSystemObject")
    ' open file for writing with Create=True, Unicode=True (USC-2 Little Endian format)
    VCS_Dir.MkDirIfNotExist obj_path
    Dim tempFileName As String
    tempFileName = VCS_File.TempFile()

    Set OutFile = FSO.CreateTextFile(tempFileName, overwrite:=True, unicode:=True)

    c = 0
    For Each fieldObj In rs.Fields
        If c <> 0 Then OutFile.Write vbTab
        c = c + 1
        OutFile.Write fieldObj.name
    Next
    OutFile.Write vbCrLf

    rs.MoveFirst
    Do Until rs.EOF
        c = 0
        For Each fieldObj In rs.Fields
            DoEvents
            If c <> 0 Then OutFile.Write vbTab
            c = c + 1
            value = rs(fieldObj.name)
            If IsNull(value) Then
                value = vbNullString
            Else
                On Error GoTo errData
                value = Replace(value, "\", "\\")
                value = Replace(value, vbCrLf, "\n")
                value = Replace(value, vbCr, "\n")
                value = Replace(value, vbLf, "\n")
                value = Replace(value, vbTab, "\t")
                On Error GoTo err
            End If
            OutFile.Write value
        Next
        OutFile.Write vbCrLf
next_field:
        rs.MoveNext
    Loop
    rs.Close
    OutFile.Close
    
    Dim path As String
    path = obj_path & to_filename(tbl_name) & ".txt"
    
    VCS_File.ConvertUcs2Utf8 tempFileName, path
    
    logger "ExportTableData", "DEBUG", "Data from '" & tbl_name & "' exported to " & path
    Kill tempFileName
    
    Exit Sub
err:
    logger "ExportTableData", "ERROR", err.Description
    Exit Sub
errData:
    logger "ExportTableData", "ERROR", "[" & fieldObj.name & "] field > Uneadable data"
    Resume next_field
End Sub


' Kill Table if Exists
Private Sub KillTable(ByVal tblName As String, db As Object)
    If TableExists(tblName) Then
        'Db.Execute "DROP TABLE [" & tblName & "]"
        run_sql "DROP TABLE [" & tblName & "]"
    End If
End Sub

Public Sub ImportLinkedTable(ByVal tblName As String, ByVal obj_path As String)
    Dim db As DAO.Database
    Dim FSO As Object
    Dim InFile As Object
    
    Set db = CurrentDb
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim tempFilePath As String
    tempFilePath = VCS_File.TempFile()
    
    ConvertUtf8Ucs2 obj_path & tblName & ".LNKD", tempFilePath
    
    ' open file for reading with Create=False, Unicode=True (USC-2 Little Endian format)
    Set InFile = FSO.OpenTextFile(tempFilePath, iomode:=ForReading, Create:=False, Format:=TristateTrue)
    
    On Error GoTo err_notable:
    DoCmd.DeleteObject acTable, tblName
    
    GoTo err_notable_fin
    
err_notable:
    err.Clear
    Resume err_notable_fin
    
err_notable_fin:
    On Error GoTo Err_CreateLinkedTable:
    
    Dim td As DAO.TableDef
    Set td = db.CreateTableDef(InFile.readline())
    
    Dim connect As String
    connect = InFile.readline()
    If InStr(1, connect, "DATABASE=.\") Then 'replace relative path with literal path
        connect = Replace(connect, "DATABASE=.\", "DATABASE=" & CurrentProject.path & "\")
    End If
    td.connect = connect
    
    td.SourceTableName = InFile.readline()
    db.TableDefs.Append td
    
    GoTo Err_CreateLinkedTable_Fin
    
Err_CreateLinkedTable:
    logger "ImportLinkedTable", "ERROR", "Unable to import " & tblName & ": " & err.Description
    Resume Err_CreateLinkedTable_Fin
    
Err_CreateLinkedTable_Fin:
    'this will throw errors if a primary key already exists or the table is linked to an access database table
    'will also error out if no pk is present
    On Error GoTo Err_LinkPK_Fin:
    
    Dim Fields As String
    Fields = InFile.readline()
    Dim Field As Variant
    Dim sql As String
    sql = "CREATE INDEX __uniqueindex ON " & td.name & " ("
    
    For Each Field In Split(Fields, ";+")
        sql = sql & "[" & Field & "]" & ","
    Next
    'remove extraneous comma
    sql = Left$(sql, Len(sql) - 1)
    
    sql = sql & ") WITH PRIMARY"
    'CurrentDb.Execute sql
    run_sql sql
    
    
    logger "ImportLinkedTable", "DEBUG", "LinkedTable " & tblName & " improted from " & obj_path & tblName & ".LNKD"

Err_LinkPK_Fin:
    On Error Resume Next
    InFile.Close
    Kill tempFilePath
    
End Sub

' Import Table Definition
Public Sub ImportTableDef(ByVal tblName As String, ByVal directory As String)
    Dim filepath As String
    
    filepath = directory & to_filename(tblName) & ".sql"
    
    Dim db As Object ' DAO.Database
    Dim FSO As Object
    Dim InFile As Object
    Dim buf As String
    Dim p As Integer
    Dim p1 As Integer
    Dim strMsg As String
    Dim S As Variant
    Dim N As Integer
    Dim i As Integer
    Dim j As Integer
    Dim tempFileName As String
    tempFileName = VCS_File.TempFile()

    N = -1
    Set FSO = CreateObject("Scripting.FileSystemObject")

    VCS_File.ConvertUtf8Ucs2 filepath, tempFileName
    
    ' open file for reading with Create=False, Unicode=True (USC-2 Little Endian format)
    'Set InFile = fso.OpenTextFile(tempFileName, iomode:=ForReading, create:=False, Format:=TristateTrue)
    Set db = CurrentDb
    
    KillTable tblName, db

    buf = ReadFile(filepath, "x-ansi")
    
    ' The following block is needed because "on update" actions may cause problems
    For Each S In Split("UPDATE|DELETE", "|")
    
      p = InStr(buf, "ON " & S & " CASCADE")
      Do While p > 0
          N = N + 1
          ReDim Preserve k(N)
          k(N).table = tblName
          k(N).isUpdate = (S = "UPDATE")
          
          buf = Left$(buf, p - 1) & Mid$(buf, p + 18)
          p = InStrRev(buf, "REFERENCES", p)
          p1 = InStr(p, buf, "(")
          k(N).foreignFields = Split(VCS_String.SubString(p1, buf, "(", ")"), ",")
          k(N).foreignTable = Trim$(Mid$(buf, p + 10, p1 - p - 10))
          p = InStrRev(buf, "CONSTRAINT", p1)
          p1 = InStrRev(buf, "FOREIGN KEY", p1)
          If (p1 > 0) And (p > 0) And (p1 > p) Then
          ' multifield index
              k(N).refFields = Split(VCS_String.SubString(p1, buf, "(", ")"), ",")
          ElseIf p1 = 0 Then
          ' single field
          End If
          p = InStr(p, "ON " & S & " CASCADE", buf)
      Loop
    Next
    
    On Error Resume Next
    
    For i = 0 To N
        strMsg = k(i).table & " to " & k(i).foreignTable
        strMsg = strMsg & "(  "
        For j = 0 To UBound(k(i).refFields)
            strMsg = strMsg & k(i).refFields(j) & ", "
        Next j
        strMsg = Left$(strMsg, Len(strMsg) - 2) & ") to ("
        For j = 0 To UBound(k(i).foreignFields)
            strMsg = strMsg & k(i).foreignFields(j) & ", "
        Next j
        strMsg = Left$(strMsg, Len(strMsg) - 2) & ") Check "
        If k(i).isUpdate Then
            strMsg = strMsg & " on update cascade " & vbCrLf
        Else
            strMsg = strMsg & " on delete cascade " & vbCrLf
        End If
    Next
    
    On Error GoTo 0
    'Db.Execute buf
    run_sql buf
    
    If Len(strMsg) > 0 Then
        OA_MsgBox strMsg, vbOKOnly, "Correct manually"
        logger "ImportTableDef", "ERROR", strMsg & " - Correct manually"
    Else
        logger "ImportTableData", "DEBUG", "TableDef '" & tblName & "' imported from " & filepath
    End If
    
    On Error Resume Next
    Kill tempFileName
End Sub

' Import the lookup table `tblName` from `source\tables`.
Public Sub ImportTableData(ByVal tblName As String, ByVal obj_path As String)
    'On Error GoTo err
    Dim db As Object ' DAO.Database
    Dim rs As Object ' DAO.Recordset
    Dim fieldObj As Object ' DAO.Field
    Dim FSO As Object
    Dim InFile As Object
    Dim c As Long, buf As String, Values() As String, value As Variant
    Dim path As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim tempFileName As String
    tempFileName = VCS_File.TempFile()
    
    path = obj_path & tblName & ".txt"
    
    VCS_File.ConvertUtf8Ucs2 path, tempFileName
    
    ' open file for reading with Create=False, Unicode=True (USC-2 Little Endian format)
    Set InFile = FSO.OpenTextFile(tempFileName, iomode:=ForReading, Create:=False, Format:=TristateTrue)
    Set db = CurrentDb

    'Db.Execute "DELETE FROM [" & tblName & "]"
    run_sql "DELETE FROM [" & tblName & "]"
    Set rs = db.OpenRecordset(tblName)
    buf = InFile.readline()
    
    Do Until InFile.AtEndOfStream
        buf = InFile.readline()
        If Len(Trim$(buf)) > 0 Then
            Values = Split(buf, vbTab)
            c = 0
            rs.AddNew
            For Each fieldObj In rs.Fields
                On Error GoTo errField
                DoEvents
                value = Values(c)
                If Len(value) = 0 Then
                    value = Null
                Else
                    value = Replace(value, "\t", vbTab)
                    value = Replace(value, "\n", vbCrLf)
                    value = Replace(value, "\\", "\")
                End If
                '** correct a bug due to internationalization
                If fieldObj.Type = dbBoolean Then value = CBool(value)
                '**
                rs(fieldObj.name) = value
                On Error GoTo err
                c = c + 1
            Next
            rs.update
        End If
    Loop

    rs.Close
    InFile.Close
    
    logger "ImportTableData", "DEBUG", "Table data '" & tblName & "' imported from " & path

    Kill tempFileName
    Exit Sub
err:
    logger "ImportTableData", "ERROR", "Table data '" & tblName & "' : Unable to import"
    Exit Sub
errField:
    logger "ImportTableData", "ERROR", fieldObj.name & " > this field can not be updated"
End Sub