|
@@ -3,24 +3,6 @@ Option Compare Database
|
|
|
Option Private Module
|
|
Option Private Module
|
|
|
Option Explicit
|
|
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)
|
|
Public Sub ExportLinkedTable(ByVal tbl_name As String, ByVal dirpath As String)
|
|
|
On Error GoTo Err_LinkedTable
|
|
On Error GoTo Err_LinkedTable
|
|
|
|
|
|
|
@@ -56,7 +38,7 @@ Public Sub ExportLinkedTable(ByVal tbl_name As String, ByVal dirpath As String)
|
|
|
Set db = CurrentDb
|
|
Set db = CurrentDb
|
|
|
Dim td As DAO.TableDef
|
|
Dim td As DAO.TableDef
|
|
|
Set td = db.TableDefs(tbl_name)
|
|
Set td = db.TableDefs(tbl_name)
|
|
|
- Dim idx As DAO.index
|
|
|
|
|
|
|
+ Dim idx As DAO.Index
|
|
|
|
|
|
|
|
For Each idx In td.Indexes
|
|
For Each idx In td.Indexes
|
|
|
If idx.Primary Then
|
|
If idx.Primary Then
|
|
@@ -86,384 +68,6 @@ Err_LinkedTable:
|
|
|
Resume Err_LinkedTable_Fin
|
|
Resume Err_LinkedTable_Fin
|
|
|
End Sub
|
|
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)
|
|
Public Sub ImportLinkedTable(ByVal tblName As String, ByVal obj_path As String)
|
|
|
Dim db As DAO.Database
|
|
Dim db As DAO.Database
|
|
|
Dim FSO As Object
|
|
Dim FSO As Object
|
|
@@ -518,12 +122,12 @@ Err_CreateLinkedTable_Fin:
|
|
|
|
|
|
|
|
Dim Fields As String
|
|
Dim Fields As String
|
|
|
Fields = InFile.readline()
|
|
Fields = InFile.readline()
|
|
|
- Dim Field As Variant
|
|
|
|
|
|
|
+ Dim field As Variant
|
|
|
Dim sql As String
|
|
Dim sql As String
|
|
|
sql = "CREATE INDEX __uniqueindex ON " & td.name & " ("
|
|
sql = "CREATE INDEX __uniqueindex ON " & td.name & " ("
|
|
|
|
|
|
|
|
- For Each Field In Split(Fields, ";+")
|
|
|
|
|
- sql = sql & "[" & Field & "]" & ","
|
|
|
|
|
|
|
+ For Each field In Split(Fields, ";+")
|
|
|
|
|
+ sql = sql & "[" & field & "]" & ","
|
|
|
Next
|
|
Next
|
|
|
'remove extraneous comma
|
|
'remove extraneous comma
|
|
|
sql = Left$(sql, Len(sql) - 1)
|
|
sql = Left$(sql, Len(sql) - 1)
|
|
@@ -540,170 +144,4 @@ Err_LinkPK_Fin:
|
|
|
InFile.Close
|
|
InFile.Close
|
|
|
Kill tempFilePath
|
|
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
|
|
End Sub
|