Attribute VB_Name = "ObjectsAndPropertiesTree"
Option Explicit
Private o_indent$
Private in_dent&
Public Interrupted$
Public nDB As Database
Public DBForImportIsOpen As Boolean
Public DisplayImportedData As Boolean
Private m1$, m2$, m3$, b1$, b2$, b3$
Public DP As Boolean
Private plist$, plistf$
Private TDB$ 'text version
Public ExportDb$
Public ImportFileName$
Public ImportHandler%
Public ImportFile$
Public IPos&, ILen&
Public espot$
Public Function AddEs$(s$)
Dim ss$
ss = Replace(s, "\", "\\")
ss = Replace(ss, "=", "\e")
ss = Replace(ss, vbCrLf, "\l")
ss = Replace(ss, vbCr, "\r")
ss = Replace(ss, vbLf, "\n")
AddEs = Replace(ss, Chr(0), "\z")
End Function
Private Sub AddK(s$, ss$)
append_loosely ExportDb, _
AddEs(s) & "=" & AddEs(ss) & vbCrLf
End Sub
'ADDK AND SKIP = FOR EMPTY VALUE
'
Private Sub AddKS(s$, ss$)
Select Case Len(ss)
Case 0: append_loosely ExportDb, _
AddEs(s) & vbCrLf
Case Else
append_loosely ExportDb, _
AddEs(s) & "=" & AddEs(ss) & vbCrLf
End Select
End Sub
Private Sub AddL()
append_loosely ExportDb, vbCrLf
End Sub
Private Sub AddNull(s$)
append_loosely ExportDb, AddEs(s) & "=\N" & vbCrLf
End Sub
Private Sub AddP(s$, ss$)
plistf = Replace(plistf, "," & UCase(s) & ", ", "")
If DisplayImportedData Then ri s & " = " & ss
LableProgress s
AddK s, ss
End Sub
Public Function DbString2Type&(s$)
Dim n&
Select Case s
Case "dbBigInt": n = dbBigInt
Case "dbBinary": n = dbBinary
Case "dbBoolean": n = dbBoolean
Case "dbByte": n = dbByte
Case "dbChar": n = dbChar
Case "dbCurrency": n = dbCurrency
Case "dbDate": n = dbDate
Case "dbDecimal": n = dbDecimal
Case "dbDouble": n = dbDouble
Case "dbFloat": n = dbFloat
Case "dbGUID": n = dbGUID
Case "dbInteger": n = dbInteger
Case "dbLong": n = dbLong
Case "dbLong": n = dbLong
Case "dbMemo": n = dbMemo
Case "dbNumeric": n = dbNumeric
Case "dbSingle": n = dbSingle
Case "dbText": n = dbText
Case "dbTime": n = dbTime
Case "dbTimeStamp": n = dbTimeStamp
Case "dbVarBinary": n = dbVarBinary
'For a QueryDef object, the possible settings and return values are shown in the following table.
Case "dbQAction": n = dbQAction
Case "dbQAppend": n = dbQAppend
Case "dbQCompound": n = dbQCompound
Case "dbQCrosstab": n = dbQCrosstab
Case "dbQDDL": n = dbQDDL
Case "dbQDelete": n = dbQDelete
Case "dbQMakeTable": n = dbQMakeTable
Case "dbQProcedure": n = dbQProcedure
Case "dbQSelect": n = dbQSelect
Case "dbQSetOperation": n = dbQSetOperation
Case "dbQSPTBulk": n = dbQSPTBulk
Case "dbQSQLPassThrough": n = dbQSQLPassThrough
Case "dbQUpdate": n = dbQUpdate
'Note To create an SQL pass-through query in a Microsoft Jet workspace, you don't need to 'explicitly 'set the Type property to dbQSQLPassThrough. The Microsoft Jet database engine 'automatically sets this 'when you create a QueryDef object and set the Connect property.
'For a Recordset object, the possible settings and return values are as follows.
Case "dbOpenTable": n = dbOpenTable
Case "dbOpenDynamic": n = dbOpenDynamic
Case "dbOpenDynaset": n = dbOpenDynaset
Case "dbOpenSnapshot": n = dbOpenSnapshot
Case "dbOpenForwardOnly": n = dbOpenForwardOnly
'For a Workspace object, the possible settings and return values are as follows.
Case "dbUseJet": n = dbUseJet
Case "dbUseODBC": n = "dbUseODBC"
Case Else: Err.Raise 2096, , "Unknown db type " & s & _
"im my program DbString2Type."
End Select
DbString2Type = n
End Function
Public Function DBType2String$(n&)
Dim s$
Select Case n
Case dbBigInt: s = "dbBigInt"
Case dbBinary: s = "dbBinary"
Case dbBoolean: s = "dbBoolean"
Case dbByte: s = "dbByte"
Case dbChar: s = "dbChar"
Case dbCurrency: s = "dbCurrency"
Case dbDate: s = "dbDate"
Case dbDecimal: s = "dbDecimal"
Case dbDouble: s = "dbDouble"
Case dbFloat: s = "dbFloat"
Case dbGUID: s = "dbGUID"
Case dbInteger: s = "dbInteger"
Case dbLong: s = "dbLong"
Case dbLongBinary: s = "dbLongBinary"
Case dbMemo: s = "dbMemo"
Case dbNumeric: s = "dbNumeric"
Case dbSingle: s = "dbSingle"
Case dbText: s = "dbText"
Case dbTime: s = "dbTime"
Case dbTimeStamp: s = "dbTimeStamp"
Case dbVarBinary: s = "dbVarBinary"
'For a QueryDef object, the possible settings and return values are shown in the following table.
Case dbQAction: s = "dbQAction"
Case dbQAppend: s = "dbQAppend"
Case dbQCompound: s = "dbQCompound"
Case dbQCrosstab: s = "dbQCrosstab"
Case dbQDDL: s = "dbQDDL"
Case dbQDelete: s = "dbQDelete"
Case dbQMakeTable: s = "dbQMakeTable"
Case dbQProcedure: s = "dbQProcedure"
Case dbQSelect: s = "dbQSelect"
Case dbQSetOperation: s = "dbQSetOperation"
Case dbQSPTBulk: s = "dbQSPTBulk"
Case dbQSQLPassThrough: s = "dbQSQLPassThrough"
Case dbQUpdate: s = "dbQUpdate"
'Note To create an SQL pass-through query in a Microsoft Jet workspace, you don't need to 'explicitly 'set the Type property to dbQSQLPassThrough. The Microsoft Jet database engine 'automatically sets this 'when you create a QueryDef object and set the Connect property.
'For a Recordset object, the possible settings and return values are as follows.
Case dbOpenTable: s = "dbOpenTable"
Case dbOpenDynamic: s = "dbOpenDynamic"
Case dbOpenDynaset: s = "dbOpenDynaset"
Case dbOpenSnapshot: s = "dbOpenSnapshot"
Case dbOpenForwardOnly: s = "dbOpenForwardOnly"
'For a Workspace object, the possible settings and return values are as follows.
Case dbUseJet: s = "dbUseJet"
Case dbUseODBC: s = "dbUseODBC"
Case Else: s = "UnknownDbType"
End Select
DBType2String = s
End Function
Private Sub DelAndNotify(s$)
plistf = Replace(plistf, "," & UCase(s) & ", ", "")
If DisplayImportedData Then ri s & " - property is not exported."
End Sub
'DeleteProcessedName from plistf
'
Private Sub DelPN(s$)
plistf = Replace(plistf, "," & UCase(s) & ", ", "")
End Sub
'DeleteProcessedName from plistf
'and type value v.
Private Sub DelPNP(s$, v$)
plistf = Replace(plistf, "," & UCase(s) & ", ", "")
If DisplayImportedData Then ri s & " = " & v
End Sub
Public Function DescribeDbType(n&)
Dim s$
Select Case n
Case dbBigInt: s = "Big Integer"
Case dbBinary: s = " Binary"
Case dbBoolean: s = " Boolean"
Case dbByte: s = " Byte"
Case dbChar: s = " Char"
Case dbCurrency: s = " Currency"
Case dbDate: s = " Date/Time"
Case dbDecimal: s = " Decimal"
Case dbDouble: s = " Double"
Case dbFloat: s = " Float"
Case dbGUID: s = " GUID"
Case dbInteger: s = " Integer"
Case dbLong: s = " Long"
Case dbLongBinary: s = " Long Binary (OLE Object)"
Case dbMemo: s = " Memo"
Case dbNumeric: s = " Numeric"
Case dbSingle: s = " Single"
Case dbText: s = " Text"
Case dbTime: s = " Time"
Case dbTimeStamp: s = " Time Stamp"
Case dbVarBinary: s = " VarBinary"
'For a QueryDef object, the possible settings and return values are shown in the following table.
Case dbQAction: s = " Action"
Case dbQAppend: s = " Append"
Case dbQCompound: s = " Compound"
Case dbQCrosstab: s = " Crosstab"
Case dbQDDL: s = " Data-definition"
Case dbQDelete: s = " Delete"
Case dbQMakeTable: s = " Make-table"
Case dbQProcedure: s = " Procedure (ODBCDirect workspaces only)"
Case dbQSelect: s = " Select"
Case dbQSetOperation: s = " Union"
Case dbQSPTBulk: s = " Used with dbQSQLPassThrough to specify a query that doesn't return records (Microsoft Jet workspaces only)."
Case dbQSQLPassThrough: s = " Pass-through (Microsoft Jet workspaces only)"
Case dbQUpdate: s = " Update"
'Note To create an SQL pass-through query in a Microsoft Jet workspace, you don't need to 'explicitly 'set the Type property to dbQSQLPassThrough. The Microsoft Jet database engine 'automatically sets this 'when you create a QueryDef object and set the Connect property.
'For a Recordset object, the possible settings and return values are as follows.
Case dbOpenTable: s = " Table (Microsoft Jet workspaces only)"
Case dbOpenDynamic: s = " Dynamic (ODBCDirect workspaces only)"
Case dbOpenDynaset: s = " Dynaset"
Case dbOpenSnapshot: s = " Snapshot"
Case dbOpenForwardOnly: s = " Forward-only"
'For a Workspace object, the possible settings and return values are as follows.
Case dbUseJet: s = " The Workspace is connected to the Microsoft Jet database engine."
Case dbUseODBC: s = " The Workspace is connected to an ODBC data source."
Case Else
s = "Unknown db type."
End Select
DescribeDbType = s
End Function
Public Sub ExportDatabase()
Dim td As TableDef
Dim nTD As TableDef
Dim FLD As Field
Dim nFLD As Field
Dim INDX As Index
Dim nINDX As Index
Dim v, s$, ss$, ws$, wi&, wj&, i&, j&
Dim p As Property
Dim NotHandledType$
Dim WhereTypeMet$
Dim Ty_pe$
Dim Rs As Recordset
Dim EC& ' exceptions counter
EC = 0
Dim EX$ 'Exceptions
DP = False
If "" = ExportDb Then
MsgBox "New name is empty."
Exit Sub
End If
If Not DBOpen Then
MsgBox "Database is not open."
Exit Sub
End If
On Error Resume Next
If Dir(ExportDb) <> "" Then
Kill ExportDb
If Err.Number > 0 Then
MsgBox "Cannot remove database " & ExportDb
Exit Sub
End If
End If
'Dim nWS As Workspace
'Set nWS = DBEngine.Workspaces(1)
'Set nWS = DBEngine.CreateWorkspace("moo_name", "umoo", "")
'If Err.Number > 0 Then
' MsgBox CStr(Err.Number) & " " & Err.Description
' Exit Sub
'End If
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
' Create database.
'------------------------------------------------------------
On Error Resume Next
Dim DBVersion$
'string:
DBVersion = Trim(MyDB.Version)
'adds L
AddK "DBVersion", DBVersion
'------------------------------------------------------------
' ef database creation
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'============================================================
' set db properties
'------------------------------------------------------------
'Dim nTransactions As Boolean '- not a table related
'phs, not important:
'nTransactions = MyDB.Transactions
'read-only:
'nDB.Transactions = nTransactions
'Dim nUpdatable As Boolean
'nUpdatable = MyDB.Updatable
'read-only:
'nDB.Updatable = nUpdatable
'CollatingOrder is already set by dbLangGeneral
Dim nQueryTimeOut%
nQueryTimeOut = MyDB.QueryTimeout
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Err.Clear
'Exit Sub
Else
AddK "QueryTimeout", CStr(nQueryTimeOut)
End If
Dim nConnect$
nConnect = MyDB.Connect
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Err.Clear
'Exit Sub
Else
AddK "Connect", nConnect
End If
'nRecordsAffected = MyDB.RecordsAffected
'read-only:
'nDB.RecordsAffected = nRecordsAffected
'Needs 16 bytes. Assume that string:
'phs, not important:
'Dim nReplicaID$
'nReplicaID = MyDB.ReplicaID
'read-only:
'nDB.ReplicaID = nReplicaID
'needs 16 bit:
'Dim nDesignMasterID$
'gives message: ... cannot be replicated ....
'nDesignMasterID = MyDB.DesignMasterID
'nDB.DesignMasterID = nDesignMasterID
'Dim nConnection
'nConnection = MyDB.connection
'v = TypeName(MyDB.connection)
'does not work:
'Set nDB.connection = nConnection
'---------------------------------------------------------
' ef db properties
'=========================================================
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
' LOOP VIA TABLES
'=============================================================
AddL 'line - mark the end of db properties
plist = ""
For Each td In MyDB.TableDefs
If "MSYS" = UCase(Left(td.Name, 4)) Then _
GoTo SkippedSystemTables
ri ve & ve & "Table" & td.Name
AddK "Table Name", td.Name
ri ""
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
ri "FIELD LOOP"
DP = False
For Each FLD In td.Fields
'========================================================
On Error Resume Next
If uInterrupted Then Exit Sub
plistf = ""
For Each p In FLD.Properties
plistf = plistf & "," & UCase(p.Name) & ", "
Next
With FLD
On Error GoTo AbsorbExceptions
'=======================================================
' setting field name:
'-------------------------------------------------------
'string
s = "Name"
ss = .Name
If DisplayImportedData Then ri ""
ri "Field Name=" & ss
If "" <> s Then
plistf = Replace(plistf, "," & UCase(s) & ", ", "")
AddK "Field Name", ss
End If
'=======================================================
'string
DelPN "Value"
'assuming that int or long:
'nFLD.Type = FLD.Properties("Type") ' .Type
'nFLD.Properties("Type") = FLD.Properties("Type") ' .Type
s = "Type"
wi = .Type
If "" <> s Then
ss = DBType2String(wi)
AddP s, ss
Select Case wi
Case dbLong, dbInteger
Case dbText, dbMemo, dbChar
Case dbDouble, dbSingle
'case dbfloat
'case dbNumeric
'Case dbCurrency
Case dbDate
Case dbTime
Case dbBoolean
Case Else
'this check is moved to a real data transfer
'because data may be empty.
'EC = EC + 1
'ws = ss & " - " & DescribeDbType(.Type)
'EX = EX & ve & "Correct conversion of type " & _
' ws & " to text is not guaranteed."
End Select
End If
'assuming that int or long:
'"not set" wim? -1, 0 ?
s = "Size"
If dbText = .Type Then
ss = CStr(.Size)
If "" <> s Then AddP s, ss
Else
DelPN s
End If
'boolean:
s = "AllowZeroLength"
If dbText = .Type Or dbMemo = .Type Then
ss = CStr(.AllowZeroLength)
If "" <> s Then AddP s, ss
Else
DelPN s
End If
'long:
s = "Attributes"
'this include: dbFixedField
' dbAutoIncrField
' dbVariableField
ss = CStr(.Attributes)
If "" <> s Then AddP s, ss
'string
'in some cases, can function as rundom ID;
s = "DefaultValue"
ss = .DefaultValue
If "" <> s Then AddP s, ss
'integer
s = "OrdinalPosition"
ss = CStr(.OrdinalPosition)
If "" <> s Then AddP s, ss
'boolean
s = "Required"
ss = .Required
If "" <> s Then AddP s, ss
'string
s = "ValidationRule"
ss = .ValidationRule
If "" <> s Then AddP s, ss
'string
s = "ValidationText"
ss = .ValidationText
If "" <> s Then AddP s, ss
'=======================================
' disabled import for properties:
'---------------------------------------
'---------------------------------------
' clearly, cannot be imported:
'---------------------------------------
'assuming that valid only for text:
'long:
s = "CollatingOrder"
If dbText = .Type Then
'COMPIELER "CANNOT ASSIGN TO READ-ONLY PROPERTY":
'nFLD.CollatingOrder = .CollatingOrder
End If
DelPN s
'string
'disabled by syntax:
DelAndNotify "ValidateOnSet"
'boolean
'COMPIELER "CANNOT ASSIGN TO READ-ONLY PROPERTY":
'(perhaps by syntax:)
s = "DataUpdatable"
DelPN s
'--------------------------------------------------
DelAndNotify "SourceField"
DelAndNotify "SourceTable"
'string
DelAndNotify "ForeignName"
DelAndNotify "ORIGINALVALUE"
'belongs to RecordSet object:
DelAndNotify "FIELDSIZE"
'not sure what is this:
DelAndNotify "VISIBLEVALUE"
DelAndNotify "ColumnOrder"
DelAndNotify "ColumnWidth"
DelAndNotify "ColumnHidden"
DelAndNotify "DecimalPlaces"
DelAndNotify "DisplayControl"
'=======================================
End With
If DisplayImportedData Then ri ve & ve
If "" <> plistf Then plist = plist & ve & ve & _
td.Name & ve & plistf
On Error Resume Next
AddL ' before next field, index, or end of table
'==================================================
Next 'ef FIELD LOOP
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
' INDEXES
'==================================================
Dim IndxName$
On Error GoTo he
s = "INDEXES"
ri ve & s
If 0 = td.Indexes.Count Then GoTo SkippedIndexes
For Each INDX In td.Indexes
On Error GoTo AbsorbIndexExceptions
If uInterrupted Then Exit Sub
s = "IndexName"
v = INDX.Name 'critical
IndxName = v
s = s & " " & v
AddK "IndexName", IndxName
ri "IndexName: " & IndxName
With INDX
s = "Fields "
ss = .Fields '+f;+g
s = s & ss
AddK "Fields", Replace(ss, "+", "") '=f;g
'this is too long method:
'Dim IndexField As Field
'Dim IndexFieldList$
'IndexFieldList = ""
'For Each IndexField In INDX.Fields
' s = IndexField.Name
' Next
s = "Unique" 'boolean:
ss = .Unique
AddK s, ss
s = "Primary" 'boolean:
ss = .Primary
AddK s, ss
s = "IgnoreNulls" 'boolean
ss = .IgnoreNulls
AddK s, ss
s = "Clustered" 'boolean:
ss = .Clustered
AddK s, ss
's = "Required" 'boolean:
'ss = .Required
's = "Foreign" 'boolean:
AddL ' after each index
End With
s = "Appending " & IndxName
ri s
Next
SkippedIndexes:
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
If 0 = EC Then
On Error GoTo he
s = "Appending table " & td.Name
ri ve & ve & "Table" & td.Name & " appended."
End If
SkippedSystemTables:
'=============================================================
Next 'EF LOOP VIA TABLES
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
If 0 <> EC Then
MsgBox "Exceptions: " & ve & Left(EX, 300) & " ... "
ri EX
Exit Sub
End If
If "" <> Replace(plist, ve, "") Then _
ri "Not-replicated properties: " & plist
ri ""
ri ""
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
ri "MOVING DATA"
'=============================================================
AddKS "Data", ""
On Error GoTo MovingDataExceptions
For Each td In MyDB.TableDefs
If uInterrupted Then Exit Sub
If "MSYS" = UCase(Left(td.Name, 4)) Then GoTo SkipDummies
wi = td.Fields.Count - 1
If 0 = wi Then GoTo NoFieldsSkipped
j = 0
Set Rs = MyDB.OpenRecordset(td.Name, dbOpenTable)
'dbOpenTable Opens a table-type Recordset object
'(Microsoft Jet workspaces only).
'dbOpenDynamic Opens a dynamic-type Recordset object, which is similar to an ODBC dynamic cursor. '(ODBCDirect workspaces only)
'dbOpenDynaset Opens a dynaset-type Recordset object, which is similar to an ODBC keyset cursor.
'dbOpenSnapshot Opens a snapshot-type Recordset object,
' which is similar to an ODBC static cursor.
'dbOpenForwardOnly Opens a forward-only-type Recordset object.
Do Until Rs.EOF
If uInterrupted Then Exit Sub
If 0 = j Then
ri ve & ve & "Table" & td.Name
AddK "Table", td.Name
AddK "FieldsNumber", CStr(wi + 1)
For i = 0 To wi
AddK "Field", td.Fields(i).Name
Next
AddL
ri ve & "Updating table " & td.Name
End If
AddK "R", CStr(j + 1)
For i = 0 To wi
If IsNull(Rs(i)) Then
AddNull ""
Else
wj = td.Fields(i).Type
Ty_pe = CStr(wj) & ", "
Select Case wj
Case dbText, dbMemo
ss = Rs(i)
Case dbChar
ss = Left(Rs(i), td.Fields(i).Size)
Case dbBoolean
ss = CStr(Rs(i))
Case dbDate
ss = Format(Rs(i), "mm/dd/yyyy")
Case dbTime
ss = Format(Rs(i), "Hh:mm:Ss")
Case dbLong, dbInteger, dbDouble, dbSingle
ss = CStr(Rs(i))
Case Else:
If InStr(NotHandledType, _
Ty_pe) = 0 Then
NotHandledType = _
NotHandledType & Ty_pe
WhereTypeMet = WhereTypeMet & _
Ty_pe & DescribeDbType(wj) & ve & _
"Table Name=" & td.Name & ve & _
"Field Name=" & td.Fields(i).Name & ve & _
"Record Number=" & CStr(j + 1)
End If
ss = CStr(Rs(i))
End Select
AddK "", ss
End If
Next
AddL
Rs.MoveNext
j = j + 1
LableProgress CStr(j)
Loop
If "" <> NotHandledType Then
EC = EC + 1
ws = "Correct handling of " & _
"this types is not quaranteed: " & ve & _
WhereTypeMet
EX = EX & ve & ws
WhereTypeMet = ""
NotHandledType = ""
End If
ri CStr(j) & " records moved to table " & td.Name
NoFieldsSkipped:
SkipDummies:
Next
Set Rs = Nothing
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
AddKS "EndOfDatabase", ""
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
' ADDITIONAL CHECKS
'-------------------------------------------------------------
If MyDB.Recordsets.Count > 0 Then
EC = EC + 1
EX = EX & ve & EC & " There are " & _
MyDB.Recordsets.Count & " RecordSets which are ignored. "
End If
If MyDB.QueryDefs.Count > 0 Then
EC = EC + 1
EX = EX & ve & EC & " There are " & _
MyDB.Recordsets.Count & " QueryDefinitions which are ignored. "
End If
If MyDB.Relations.Count > 0 Then
EC = EC + 1
EX = EX & ve & EC & " There are " & _
MyDB.Recordsets.Count & " Relations which are ignored. "
End If
'-------------------------------------------------------------
' ef ADDITIONAL CHECKS
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'-------------------------------------------------------------
' FINAL REPORT
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
If 0 <> EC Then
s = "Export attemt is done. Exceptions are: " & ve & EX
ri s
MsgBox Left(s, 500) & " ... "
Else
s = "Database " & ImportFromDatabaseName & ve & _
"has been succesfully exported to" & ve & _
ExportDb
ri ve & s
MsgBox s
End If
'-------------------------------------------------------------
Exit Sub
AbsorbExceptions:
EC = EC + 1
EX = EX & EC & " Exc in Field Property = " & s & ve & _
Err.Number & " " & Err.Description & ve
s = ""
Resume Next
AbsorbIndexExceptions:
EC = EC + 1
EX = EX & EC & " Exc in Index = " & s & ve & _
Err.Number & " " & Err.Description & ve
s = ""
Resume Next
MovingDataExceptions:
EC = EC + 1
EX = EX & EC & " Exc in Moving data: " & s & ve & _
Err.Number & " " & Err.Description & ve
s = ""
ri EX
Exit Sub
'Resume Next
he: s = s & ve & "Process Terminated: " & ve & _
Err.Number & " " & Err.Description & ve & _
espot
If "" <> EX Then
s = s & ve & "Another exceptions: " & ve & EX
End If
ri s
MsgBox s
Exit Sub
End Sub
Public Sub ImportDatabase(NewPath$)
Dim nTD As TableDef
Dim NewTableName$
Dim nFLD As Field
Dim nINDX As Index
Dim v, s$, ss$, sss$, i&, ii&, j&
Dim ws$
Dim IndxName$
Dim Rs As Recordset
Dim nRS As Recordset
Dim wi&, SavedFields$(), CurrentFI&()
Dim EC& ' exceptions counter
EC = 0
Dim EX$ 'Exceptions
DP = False
If "" = NewPath Then
MsgBox "New name is empty."
Exit Sub
End If
On Error Resume Next
If Dir(NewPath) <> "" Then
Kill NewPath
If Err.Number > 0 Then
MsgBox "Cannot remove database " & NewPath
Exit Sub
End If
End If
If MyWs Is Nothing Then
'name, user, password
Set MyWs = DBEngine.CreateWorkspace("MyNewWorkspace", "admin", "")
End If
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Exit Sub
End If
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
' Create database.
'------------------------------------------------------------
On Error Resume Next
Dim DBVersion$
'string:
If "X" = ReadKC("DBVersion", DBVersion) Then Exit Sub
'adds L
Select Case DBVersion
Case "1.0": Set nDB = _
MyWs.CreateDatabase(NewPath, dbLangGeneral, dbVersion10)
Case "1.1": Set nDB = _
MyWs.CreateDatabase(NewPath, dbLangGeneral, dbVersion11)
Case "2.0": Set nDB = _
MyWs.CreateDatabase(NewPath, dbLangGeneral, dbVersion20)
Case "3.0": Set nDB = _
MyWs.CreateDatabase(NewPath, dbLangGeneral, dbVersion30)
End Select
If Err.Number > 0 Then
MsgBox "Database creation exception." & ve & _
Err.Number & " " & Err.Description
Exit Sub
End If
DBForImportIsOpen = True
'------------------------------------------------------------
' ef database creation
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'============================================================
' set db properties
'------------------------------------------------------------
Dim nQueryTimeOut%
If "X" = ReadKC("QueryTimeOut", ss) Then Exit Sub
nDB.QueryTimeout = CInt(ss)
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Err.Clear
Exit Sub
End If
Dim nConnect$
If "X" = ReadKC("Connect", nConnect) Then Exit Sub
nDB.Connect = nConnect
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Err.Clear
Exit Sub
End If
'---------------------------------------------------------
' ef db properties
'=========================================================
If "X" = ReadOneOrMoreLines(s, ss) Then Exit Sub
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
LOOP_VIA_TABLES:
'=============================================================
If UCase(s) <> "TABLE NAME" Then GoTo MOVE_DATA
NewTableName = ss
ri ve & ve & "Table " & NewTableName
Set nTD = nDB.CreateTableDef()
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Exit Sub
End If
nTD.Name = NewTableName
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Exit Sub
End If
ri ""
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
ri "FIELD LOOP"
If "X" = ReadK(s, ss) Then Exit Sub
FieldLoop:
'========================================================
On Error Resume Next
'=======================================================
' setting field name:
'-------------------------------------------------------
If "FIELD NAME" <> UCase(s) Then GoTo Indexes
Set nFLD = nTD.CreateField
nFLD.Name = ss
'=======================================================
On Error GoTo AbsorbExceptions
With nFLD
'assuming that int or long:
If "X" = ReadKC("Type", ss) Then Exit Sub
.Type = DbString2Type(ss) 'CLng(ss)
'assuming that int or long:
'"not set" wim? -1, 0 ?
If dbText = .Type Then
If "X" = ReadKC("Size", ss) Then Exit Sub
.Size = CLng(.Size)
End If
'boolean:
If dbText = .Type Or dbMemo = .Type Then
If "X" = ReadKC("AllowZeroLength", ss) Then Exit Sub
.AllowZeroLength = CBool(ss)
End If
'long:
ss = CStr(.Attributes)
If "X" = ReadKC("Attributes", ss) Then Exit Sub
nFLD.Attributes = CLng(ss)
'string
'in some cases, can function as rundom ID;
If "X" = ReadKC("DefaultValue", ss) Then Exit Sub
.DefaultValue = ss
'integer
If "X" = ReadKC("OrdinalPosition", ss) Then Exit Sub
.OrdinalPosition = CInt(ss)
'boolean
If "X" = ReadKC("Required", ss) Then Exit Sub
.Required = CBool(ss)
'string
If "X" = ReadKC("ValidationRule", ss) Then Exit Sub
.ValidationRule = ss
'string
If "X" = ReadKC("ValidationText", ss) Then Exit Sub
.ValidationText = ss
On Error Resume Next
If 0 = EC Then
nTD.Fields.Append nFLD
End If
If Err.Number > 0 Then Err.Clear
If "X" = ReadOneOrMoreLines(s, ss) Then Exit Sub
End With
'==================================================
GoTo FieldLoop
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
Indexes: If "INDEXNAME" <> UCase(s) Then
If 0 = EC Then
On Error GoTo he
espot = "Appending table " & NewTableName
nDB.TableDefs.Append nTD
ri ve & ve & "Table" & NewTableName & " appended."
GoTo LOOP_VIA_TABLES
End If
End If
'==================================================
On Error GoTo AbsorbIndexExceptions
v = ss 'critical
IndxName = ss
s = IndxName
ri "Index: " & IndxName
Set nINDX = nTD.CreateIndex(v)
With nINDX
s = "Fields"
If "X" = ReadKC(s, ss) Then Exit Sub
.Fields = ss '=f;g
s = "Unique" 'boolean:
If "X" = ReadKC(s, ss) Then Exit Sub
.Unique = CBool(ss)
s = "Primary" 'boolean:
If "X" = ReadKC(s, ss) Then Exit Sub
.Primary = CBool(ss)
s = "IgnoreNulls" 'boolean
If "X" = ReadKC(s, ss) Then Exit Sub
.IgnoreNulls = CBool(ss)
s = "Clustered" 'boolean:
If "X" = ReadKC(s, ss) Then Exit Sub
.Clustered = CBool(ss)
End With
espot = "Appending " & IndxName
ri espot
nTD.Indexes.Append nINDX
If "X" = ReadOneOrMoreLines(s, ss) Then Exit Sub
GoTo Indexes
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
MOVE_DATA:
nDB.Close
DBForImportIsOpen = False
If 0 <> EC Then
MsgBox "Exceptions: " & ve & Left(EX, 300) & " ... "
ri EX
Exit Sub
End If
ri ""
ri ""
ri "MOVING DATA"
'=============================================================
If "DATA" <> UCase(s) Then
MsgBox "Corrupted data part: missed title ""Data""."
Exit Sub
End If
On Error GoTo he
Set nDB = MyWs.OpenDatabase(NewPath)
DBForImportIsOpen = True
On Error GoTo MovingDataExceptions
If "X" = ReadK(s, ss) Then Exit Sub
MoveTableAgain:
If "TABLE" <> UCase(s) Then GoTo END_OF_DATA
Set nTD = nDB.TableDefs(ss)
If uInterrupted Then Exit Sub
ri ve & ve & "Table" & nTD.Name
If "X" = ReadKC("FieldsNumber", ss) Then Exit Sub
wi = nTD.Fields.Count - 1
j = 0
ReDim SavedFields(wi)
ReDim CurrentFI(wi)
For i = 0 To wi
If "X" = ReadKC("Field", ss) Then Exit Sub
SavedFields(i) = ss
Next
For i = 0 To wi
For ii = 0 To wi
If UCase(SavedFields(ii)) = UCase(nTD.Fields(i).Name) Then
CurrentFI(ii) = i
End If
Next
Next
MoveNextRecord:
If uInterrupted Then Exit Sub
If "X" = ReadOneOrMoreLines(s, ss) Then Exit Sub
If "R" <> UCase(s) Then
If 0 <> j Then ri CStr(j) & _
" record(s) moved to table " & nTD.Name
GoTo MoveTableAgain
End If
If j + 1 <> CLng(ss) Then
MsgBox "Records numbers do not match. Corrupted Import File."
Exit Sub
End If
If DisplayImportedData Then ri "Record " & ss
If 0 = j Then
Set nRS = nDB.OpenRecordset(nTD.Name, dbOpenDynaset)
ri ve & "Updating table " & nTD.Name
End If
nRS.AddNew
For ii = 0 To wi
'I DID NOT FIND NOTE IN MS DOCUMENTATION
'THAT THIS ENUMERATION IS CONSISTENT FROM
'RECORD TO RECORD, BUT I AM ASSUMING IT
'AddK "", Rs(i)
sss = ReadK("", ss)
Select Case sss
Case "X": Exit Sub
Case "N": 'null, do nothing
Case "K": 'not corrupted file
i = CurrentFI(ii)
Select Case nTD.Fields(i).Type
Case dbText, dbMemo
nRS.Fields(i) = ss
Case dbChar
'hope this is a correct conversion:
ws = String(nTD.Fields(i).Size, " ")
LSet ws = ss
nRS.Fields(i) = ss
Case dbBoolean
nRS.Fields(i) = CBool(ss)
Case dbSingle
nRS.Fields(i) = CSng(ss)
Case dbDouble
nRS.Fields(i) = CDbl(ss)
Case dbFloat
'not sure:
nRS.Fields(i) = CSng(ss)
Case dbLong
nRS.Fields(i) = CLng(ss)
Case dbInteger
nRS.Fields(i) = CInt(ss)
Case Else: nRS.Fields(i) = ss
End Select
End Select
Next
nRS.Update
j = j + 1
If DisplayImportedData Then ri CStr(j) & " record(s) were moved."
LableProgress CStr(j)
GoTo MoveNextRecord
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
END_OF_DATA:
Set nRS = Nothing
Set Rs = Nothing
nDB.Close
DBForImportIsOpen = False
If "ENDOFDATABASE" <> UCase(s) Then
MsgBox "Missed ""EndOfDatabase"" last line."
End If
'-------------------------------------------------------------
' FINAL REPORT
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
If 0 <> EC Then
s = "Import attemt is done. Exceptions are: " & ve & EX
MsgBox Left(s, 500) & " ... "
ri s
Else
MsgBox "Database " & ImportFileName & ve & _
"has been succesfully imported to " & ve & NewPath
End If
'-------------------------------------------------------------
Exit Sub
AbsorbExceptions:
EC = EC + 1
EX = EX & EC & " Exc in Field Property = " & s & ve & _
Err.Number & " " & Err.Description & ve
s = ""
Resume Next
AbsorbIndexExceptions:
EC = EC + 1
EX = EX & EC & " Exc in Index = " & s & ve & _
Err.Number & " " & Err.Description & ve
s = ""
Resume Next
MovingDataExceptions:
ws = " Exc in Moving data: " & s & ve & _
Err.Number & " " & Err.Description & ve
ri ws
EC = EC + 1
EX = EX & EC & ws
s = ""
Resume Next
he: s = s & ve & "Process Terminated: " & ve & _
Err.Number & " " & Err.Description & ve & espot
If "" <> EX Then
s = s & ve & "Another exceptions: " & ve & EX
End If
ri s
MsgBox s
Exit Sub
End Sub
Private Sub LableProgress(s$)
frmMain.lblProgress = s
End Sub
Public Function OpenImportFile$()
On Error GoTo he
ImportHandler = FreeFile
ILen = FileLen(ImportFileName)
ImportFile = String(ILen, " ")
Open ImportFileName For Binary Access Read Shared As ImportHandler
Get #ImportHandler, 1, ImportFile
Close ImportHandler
IPos = 1
Exit Function
he:
MsgBox "Exception " & Err.Number & " " & _
Err.Description & vbCrLf & _
"when opening " & ImportFileName
Exit Function
End Function
Public Function ListDbTypes$()
Dim s$
s = "MJ - Microsoft Jet. DS - Data Source." & ve
s = s & ve & dbBigInt & " - dbBigInt - Big Integer"
s = s & ve & dbBinary & " - dbBinary - Binary"
s = s & ve & dbBoolean & " - dbBoolean - Boolean"
s = s & ve & dbByte & " - dbByte - Byte"
s = s & ve & dbChar & " - dbChar - Char"
s = s & ve & dbCurrency & " - dbCurrency - Currency"
s = s & ve & dbDate & " - dbDate - Date/Time"
s = s & ve & dbDecimal & " - dbDecimal - Decimal"
s = s & ve & dbDouble & " - dbDouble - Double"
s = s & ve & dbFloat & " - dbFloat - Float"
s = s & ve & dbGUID & " - dbGUID - GUID"
s = s & ve & dbInteger & " - dbInteger - Integer"
s = s & ve & dbLong & " - dbLong - Long"
s = s & ve & dbLongBinary & " - dbLongBinary - Long Binary (OLE Object)"
s = s & ve & dbMemo & " - dbMemo - Memo"
s = s & ve & dbNumeric & " - dbNumeric - Numeric"
s = s & ve & dbSingle & " - dbSingle - Single"
s = s & ve & dbText & " - dbText - Text"
s = s & ve & dbTime & " - dbTime - Time"
s = s & ve & dbTimeStamp & " - dbTimeStamp - Time Stamp"
s = s & ve & dbVarBinary & " - dbVarBinary - VarBinary"
s = s & ve & ve & "QueryDef object. Settings and return alues: "
s = s & ve & dbQAction & " - dbQAction - Action"
s = s & ve & dbQAppend & " - dbQAppend - Append"
s = s & ve & dbQCompound & " - dbQCompound - Compound"
s = s & ve & dbQCrosstab & " - dbQCrosstab - Crosstab"
s = s & ve & dbQDDL & " - dbQDDL - Data-definition"
s = s & ve & dbQDelete & " - dbQDelete - Delete"
s = s & ve & dbQMakeTable & " - dbQMakeTable - Make-table"
s = s & ve & dbQProcedure & " - dbQProcedure - Procedure (ODBCDirect Workspaces)"
s = s & ve & dbQSelect & " - dbQSelect - Select"
s = s & ve & dbQSetOperation & " - dbQSetOperation - Union"
s = s & ve & dbQSPTBulk & " - dbQSPTBulk - Used with dbQSQLPassThrough." & ve & _
"MJ Workspaces only. Specifying a query that doesn't return records."
s = s & ve & dbQSQLPassThrough & " - dbQSQLPassThrough - MJ Workspaces. Pass-through."
s = s & ve & dbQUpdate & " - dbQUpdate - Update"
s = s & ve & ve & "Recordset Object:"
s = s & ve & dbOpenTable & " - dbOpenTable - Table. MJ Workspaces."
s = s & ve & dbOpenDynamic & " - dbOpenDynamic - Dynamic. ODBCDirect Workspaces."
s = s & ve & dbOpenDynaset & " - dbOpenDynaset - Dynaset"
s = s & ve & dbOpenSnapshot & " - dbOpenSnapshot - Snapshot"
s = s & ve & dbOpenForwardOnly & " - dbOpenForwardOnly - Forward-only"
s = s & ve & dbUseJet & " - dbUseJet - The WS is connected to the MJD engine."
s = s & ve & dbUseODBC & " - dbUseODBC - The WS is connected to an ODBC DS."
ListDbTypes = s
End Function
Private Function ReadK$(s$, ss$)
Dim ws$, pos&
Dim NL As Boolean
ReadK = "K" 'normal parsing
If IPos > ILen Then
'end found:
ReadK = "E"
Exit Function
End If
pos = InStr(IPos, ImportFile, vbCrLf)
If 0 = pos Then
pos = ILen + 1
End If
ws = Mid(ImportFile, IPos, pos - IPos)
IPos = pos + 2
If "" = ws Then
ReadK = "L"
s = ""
ss = ""
Exit Function
End If
pos = InStr(ws, "=")
If 0 = pos Then
s = ws
ss = ""
Else
s = Mid(ws, 1, pos - 1)
ss = Mid(ws, pos + 1)
End If
ss = StripEs(ss, NL)
If NL Then ReadK = "N"
s = StripEs(s, NL)
If NL Then ReadK = "N"
If DisplayImportedData Then ri "K: " & s & " = " & ss
End Function
Public Function ReadKC$(s$, ss$)
Dim c$, sc$, ws$
sc = s
c = ReadK(s, ss)
Select Case c
Case "K": 'good
If UCase(s) <> UCase(sc) Then
c = "X"
ws = "Key " & sc & " is expected." & ve & _
"Key " & s & " is encountered."
End If
Case Else:
Select Case c
Case "E": ws = "End of file encoutered."
Case "N": ws = "NULL value encountered."
Case "L": ws = "Empty line encountered."
End Select
c = "X"
End Select
If "K" <> c Then
ws = "Corrupted key=value pair encoutered " & ve & _
ws & ve & _
"key:" & s & _
"possible value:" & ss
ri ws
MsgBox ws
Interrupted = "Y"
End If
ReadKC = c
End Function
Public Function ReadL$()
Dim s$, ss$, c$, ws$
c = ReadK(s, ss)
If "L" <> c Then
ws = "Missed Line in import file."
ri ws
MsgBox ws
ReadL = "X"
Interrupted = "Y"
End If
End Function
Public Function ReadOneOrMoreLines$(s$, ss$)
Dim c$
c = ReadL
If "X" = s Then GoTo ExitFunction
c = ReadSkippingLines(s, ss)
ExitFunction:
ReadOneOrMoreLines = c
End Function
Public Function ReadSkippingLines$(s$, ss$)
Dim c$
again:
If uInterrupted Then
ReadSkippingLines = "X"
Exit Function
End If
c = ReadK(s, ss)
If "L" = c Then GoTo again
ReadSkippingLines = c
End Function
Public Function StripEs$(s$, NL As Boolean)
Dim ss$
If InStr(s, "\N") > 0 Then
NL = True
Exit Function
Else
NL = False
End If
ss = Replace(s, "\z", Chr(0))
ss = Replace(ss, "\n", vbLf)
ss = Replace(ss, "\r", vbCr)
ss = Replace(ss, "\l", vbCrLf)
StripEs = Replace(ss, "\\", "\")
End Function
'MyWs must aready exist
'MyDb must be already open.
'
'
'EXCEPTIONS NUMBERS:
'vital to find: in Platform SDK/Database and Messaging Services/
' /Trappable Microsoft Jet and DAO Errors
'
Public Sub RecreateDatabase(NewPath$)
Dim td As TableDef
Dim nTD As TableDef
Dim FLD As Field
Dim nFLD As Field
Dim INDX As Index
Dim nINDX As Index
Dim nDB As Database
Dim v, s$, ss$, i&, j&
Dim p As Property
Dim EC& ' exceptions counter
EC = 0
Dim ve, vr, vl
ve = vbCrLf
vr = vbCr
vl = vbLf
Dim EX$ 'Exceptions
DP = False
If "" = NewPath Then
MsgBox "New name is empty."
Exit Sub
End If
If Not DBOpen Then
MsgBox "Database is not open."
Exit Sub
End If
On Error Resume Next
If Dir(NewPath) <> "" Then
Kill NewPath
If Err.Number > 0 Then
MsgBox "Cannot remove database " & NewPath
Exit Sub
End If
End If
Dim nWS As Workspace
'Set nWS = DBEngine.Workspaces(1)
'Set nWS = DBEngine.CreateWorkspace("moo_name", "umoo", "")
'If Err.Number > 0 Then
' MsgBox CStr(Err.Number) & " " & Err.Description
' Exit Sub
'End If
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
' Create database.
'------------------------------------------------------------
On Error Resume Next
Dim DBVersion$
'string:
DBVersion = Trim(MyDB.Version)
Select Case DBVersion
Case "1.0": Set nDB = _
MyWs.CreateDatabase(NewPath, dbLangGeneral, dbVersion10)
Case "1.1": Set nDB = _
MyWs.CreateDatabase(NewPath, dbLangGeneral, dbVersion11)
Case "2.0": Set nDB = _
MyWs.CreateDatabase(NewPath, dbLangGeneral, dbVersion20)
Case "3.0": Set nDB = _
MyWs.CreateDatabase(NewPath, dbLangGeneral, dbVersion30)
End Select
If Err.Number > 0 Then
MsgBox "Database creation exception." & ve & _
Err.Number & " " & Err.Description
Exit Sub
End If
'------------------------------------------------------------
' ef database creation
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'============================================================
' set db properties
'------------------------------------------------------------
Dim nTransactions As Boolean '- not a table related
'phs, not important:
nTransactions = MyDB.Transactions
'read-only:
'nDB.Transactions = nTransactions
Dim nUpdatable As Boolean
Dim nQueryTimeOut%
'nUpdatable = MyDB.Updatable
'read-only:
'nDB.Updatable = nUpdatable
'CollatingOrder is already set by dbLangGeneral
nQueryTimeOut = MyDB.QueryTimeout
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Err.Clear
'Exit Sub
End If
Dim nConnect$
nConnect = MyDB.Connect
nDB.Connect = nConnect
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Err.Clear
'Exit Sub
End If
Dim nRecordsAffected&
'nRecordsAffected = MyDB.RecordsAffected
'read-only:
'nDB.RecordsAffected = nRecordsAffected
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Err.Clear
'Exit Sub
End If
'Needs 16 bytes. Assume that string:
'phs, not important:
'Dim nReplicaID$
'nReplicaID = MyDB.ReplicaID
'read-only:
'nDB.ReplicaID = nReplicaID
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Err.Clear
'Exit Sub
End If
'needs 16 bit:
Dim nDesignMasterID$
'gives message: ... cannot be replicated ....
nDesignMasterID = MyDB.DesignMasterID
'nDB.DesignMasterID = nDesignMasterID
If Err.Number > 0 Then
MsgBox "DesignMasterID exception" & ve & _
Err.Number & " " & Err.Description
Err.Clear
'Exit Sub
End If
'Dim nConnection
'nConnection = MyDB.connection
'v = TypeName(MyDB.connection)
'does not work:
'Set nDB.connection = nConnection
'---------------------------------------------------------
' ef db properties
'=========================================================
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
' LOOP VIA TABLES
'=============================================================
plist = ""
For Each td In MyDB.TableDefs
ri ve & ve & "Table" & td.Name
If "MSYS" = UCase(Left(td.Name, 4)) Then _
GoTo SkippedSystemTables
Set nTD = nDB.CreateTableDef()
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Exit Sub
End If
nTD.Name = td.Name
If Err.Number > 0 Then
MsgBox CStr(Err.Number) & " " & Err.Description
Exit Sub
End If
ri ""
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
ri "FIELD LOOP"
DP = False
For Each FLD In td.Fields
'========================================================
On Error Resume Next
plistf = ""
For Each p In FLD.Properties
plistf = plistf & "^" & UCase(p.Name) & ", "
Next
Set nFLD = nTD.CreateField
With FLD
On Error GoTo AbsorbExceptions
'=======================================================
' setting field name:
'-------------------------------------------------------
'string
s = "Name"
nFLD.Name = .Name
If "" <> s Then DelPNP s, .Name
'=======================================================
'string
DelPN "Value"
'assuming that int or long:
'nFLD.Type = FLD.Properties("Type") ' .Type
'nFLD.Properties("Type") = FLD.Properties("Type") ' .Type
s = "Type"
nFLD.Type = .Type
If "" <> s Then DelPNP s, CStr(.Type)
'assuming that int or long:
'"not set" wim? -1, 0 ?
s = "Size"
If dbText = .Type Then
nFLD.Size = .Size
If "" <> s Then DelPNP s, CStr(.Size)
Else
DelPN s
End If
'boolean:
s = "AllowZeroLength"
If dbText = .Type Or dbMemo = .Type Then
nFLD.AllowZeroLength = .AllowZeroLength
If "" <> s Then DelPNP s, CStr(.AllowZeroLength)
Else
DelPN s
End If
'assuming that valid only for text:
'long:
s = "CollatingOrder"
If dbText = .Type Then
'COMPIELER "CANNOT ASSIGN TO READ-ONLY PROPERTY":
'nFLD.CollatingOrder = .CollatingOrder
DelPN s
Else
DelPN s
End If
'long:
s = "Attributes"
nFLD.Attributes = .Attributes
If "" <> s Then DelPNP s, CStr(.Attributes)
'boolean
'COMPIELER "CANNOT ASSIGN TO READ-ONLY PROPERTY":
'(perhaps by syntax:)
s = "DataUpdatable"
'nFLD.DataUpdatable = .DataUpdatable
DelPN s
'string
'in some cases, can function as rundom ID;
s = "DefaultValue"
nFLD.DefaultValue = .DefaultValue
If "" <> s Then
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
ri s & " = " & .DefaultValue
End If
'integer
s = "OrdinalPosition"
nFLD.OrdinalPosition = .OrdinalPosition
If "" <> s Then
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
ri s & " = " & .OrdinalPosition
End If
'boolean
s = "Required"
nFLD.Required = .Required
If "" <> s Then
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
ri s & " = " & .Required
End If
s = "SourceField"
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
s = "SourceTable"
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
'string
s = "ValidationRule"
nFLD.ValidationRule = .ValidationRule
If "" <> s Then
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
ri s & " = " & .ValidationRule
End If
'string
s = "ValidationText"
nFLD.ValidationText = .ValidationText
If "" <> s Then
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
ri s & " = " & .ValidationText
End If
'this is part of relation object:
'string
s = "ForeignName"
'nFLD.ForeignName = .ForeignName
If "" <> s Then
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
End If
'string
'disabled by syntax:
s = "ValidateOnSet"
'nFLD.ValidateOnSet = .ValidateOnSet
'If "" <> s Then
plistf = Replace(plistf, "^" & UCase(s) & ", ", "")
' 'ri s & " = " & .ValidateOnSet
'End If
'=======================================
' disabled updates:
plistf = Replace(plistf, "^" & "ORIGINALVALUE" & ", ", "")
'belongs to RecordSet object:
plistf = Replace(plistf, "^" & "FIELDSIZE" & ", ", "")
'not sure what is this:
plistf = Replace(plistf, "^" & "VISIBLEVALUE" & ", ", "")
'=======================================
End With
ri ve & ve & ve
If "" <> plistf Then plist = plist & ve & ve & _
td.Name & ve & plistf
On Error Resume Next
If 0 = EC Then
nTD.Fields.Append nFLD
End If
If Err.Number > 0 Then Err.Clear
'==================================================
Next 'ef FIELD LOOP
DP = False
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
' INDEXES
'==================================================
Dim IndxName$
On Error GoTo he
s = "INDEXES"
ri ve & s
If 0 = td.Indexes.Count Then GoTo SkippedIndexes
For Each INDX In td.Indexes
On Error GoTo AbsorbIndexExceptions
s = "IndexName "
v = INDX.Name 'critical
IndxName = v
s = s & IndxName
ri "Index: " & IndxName
Set nINDX = nTD.CreateIndex(v)
With INDX
s = "Fields "
ss = .Fields '+f;+g
s = s & ss
'nINDX.Fields = .Fields
nINDX.Fields = Replace(ss, "+", "") '=f;g
'this is too long method:
'Dim IndexField As Field
'Dim IndexFieldList$
'IndexFieldList = ""
'For Each IndexField In INDX.Fields
' s = IndexField.Name
' Next
s = "Unique" 'boolean:
nINDX.Unique = .Unique
s = "Primary" 'boolean:
nINDX.Primary = .Primary
s = "IgnoreNulls" 'boolean
nINDX.IgnoreNulls = .IgnoreNulls
s = "Clustered" 'boolean:
nINDX.Clustered = .Clustered
s = "Required" 'boolean:
ss = .Required
nINDX.Required = CBool(ss) ' .Required
's = "Foreign" 'boolean:
'nINDX.Foreign = .Foreign
End With
s = "Appending " & IndxName
ri s
nTD.Indexes.Append nINDX
Next
SkippedIndexes:
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
If 0 = EC Then
On Error GoTo he
s = "Appending table " & td.Name
nDB.TableDefs.Append nTD
ri ve & ve & "Table" & td.Name & " appended."
End If
SkippedSystemTables:
'=============================================================
Next 'EF LOOP VIA TABLES
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
If 0 <> EC Then
MsgBox "Exceptions: " & ve & Left(EX, 300) & " ... "
ri EX
Exit Sub
End If
nDB.Close
If "" <> Replace(plist, ve, "") Then _
ri "Not-replicated properties: " & plist
ri ""
ri ""
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
ri "MOVING DATA"
'=============================================================
On Error GoTo he
Set nDB = MyWs.OpenDatabase(NewPath)
On Error GoTo MovingDataExceptions
For Each td In MyDB.TableDefs
If uInterrupted Then Exit Sub
If "MSYS" = UCase(Left(td.Name, 4)) Then GoTo SkipDummies
'If "TRANSACTION" = UCase(td.Name) Then GoTo SkipDummies
ri ve & ve & "Table" & td.Name
Dim Rs As Recordset
Dim nRS As Recordset
'dbOpenTable Opens a table-type Recordset object
'(Microsoft Jet workspaces only).
'dbOpenDynamic Opens a dynamic-type Recordset object, which is similar to an ODBC dynamic cursor. '(ODBCDirect workspaces only)
'dbOpenDynaset Opens a dynaset-type Recordset object, which is similar to an ODBC keyset cursor.
'dbOpenSnapshot Opens a snapshot-type Recordset object,
' which is similar to an ODBC static cursor.
'dbOpenForwardOnly Opens a forward-only-type Recordset object.
Dim wi&
wi = td.Fields.Count - 1
ri ve & "Updating table " & td.Name
Set Rs = MyDB.OpenRecordset(td.Name, dbOpenTable)
Set nRS = nDB.OpenRecordset(td.Name, dbOpenDynaset)
j = 0
Do Until Rs.EOF
If uInterrupted Then Exit Sub
nRS.AddNew
For i = 0 To wi
nRS(i) = Rs(i)
Next
nRS.Update
Rs.MoveNext
j = j + 1
Loop
ri CStr(j) & " records moved to table " & td.Name
SkipDummies:
Next
Set nRS = Nothing
Set Rs = Nothing
nDB.Close
'MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
' ADDITIONAL CHECKS
'-------------------------------------------------------------
If MyDB.Recordsets.Count > 0 Then
EC = EC + 1
EX = EX & ve & EC & " There are " & _
MyDB.Recordsets.Count & " RecordSets which are ignored. "
End If
If MyDB.QueryDefs.Count > 0 Then
EC = EC + 1
EX = EX & ve & EC & " There are " & _
MyDB.Recordsets.Count & " QueryDefinitions which are ignored. "
End If
If MyDB.Relations.Count > 0 Then
EC = EC + 1
EX = EX & ve & EC & " There are " & _
MyDB.Recordsets.Count & " Relations which are ignored. "
End If
'-------------------------------------------------------------
' ef ADDITIONAL CHECKS
'mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
'-------------------------------------------------------------
' FINAL REPORT
'- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
If 0 <> EC Then
s = "Replication attemt is done. Exceptions are: " & ve & EX
MsgBox Left(s, 500) & " ... "
ri s
Else
MsgBox "Database " & NewPath & ve & _
"has been succesfully replicated."
End If
'-------------------------------------------------------------
Exit Sub
AbsorbExceptions:
EC = EC + 1
EX = EX & EC & " Exc in Field Property = " & s & ve & _
Err.Number & " " & Err.Description & ve
s = ""
Resume Next
AbsorbIndexExceptions:
EC = EC + 1
EX = EX & EC & " Exc in Index = " & s & ve & _
Err.Number & " " & Err.Description & ve
s = ""
Resume Next
MovingDataExceptions:
EC = EC + 1
EX = EX & EC & " Exc in Moving data: " & s & ve & _
Err.Number & " " & Err.Description & ve
s = ""
Resume Next
he: s = s & ve & "Process Terminated: " & ve & _
Err.Number & " " & Err.Description
If "" <> EX Then
s = s & ve & "Another exceptions: " & ve & EX
End If
ri s
MsgBox s
Exit Sub
End Sub
Public Sub ri(s$)
o_indent = String(in_dent * 3, " ")
If Not DP Then frmMain.rl _
o_indent & Replace(s, ve, ve & o_indent)
End Sub
Public Function uInterrupted() As Boolean
DoEvents
uInterrupted = False
If "Y" = Interrupted Then
uInterrupted = True
If DBForImportIsOpen Then
DBForImportIsOpen = False
nDB.Close
End If
End If
End Function