On Mon, 14 Jul 2008 11:42:21 -0700 (PDT), DeanL <de*************@yahoo.com>
wrote:
>Hi guys,
Does anyone know of a way to create multiple tables using information
stored in one table? I have a table with 4 columns (TableName,
ColumnName, DataType, DataSize) and wanted to know if there is a way
to use the information in this table to create the many tables that
are listed in the source table instead of creating each table
individually?
Many thanks for any help you can offer.
Dean...
I use 3 tables to create a database containing temporary tables I sometimes use
for reporting. You may be able to use parts of the code below to achieve what
you want.
1. abfTempTableNames
TempTableName - Text (PK)
2. abfTempTableFieldNames
TempTableName - Text (PK)
FieldName - Text (PK)
FieldType - Long
FieldSize - Integer
AutoNum - Y/N
3. abfTempTableIndexes
TempIndexID - AutoNum (PK)
TempTableName - Text
Fields - Text (Format = +FieldName for single field index
or +FieldName1+FieldName2+FieldName3 for multi field index)
IgnoreNulls - Y/N
Name - Text
Primary - Y/N
Required - Y/N
Unique - Y/N
'************************************************* ********************
Function fCreateTempDB() As Boolean
Dim BFws As Workspace
Dim Bfdb As Database
Dim CurDB As Database
Dim prpLoop As Property
Dim strNewDB As String
Dim rstTbls As Recordset
Dim rstFlds As Recordset
Dim rstInds As Recordset
Dim tdf As TableDef
Dim tdfNew As TableDef
Dim strSQL As String
Dim fldNew As Field
Dim indNew As Index
Dim varRet As Variant
Dim strFields As String
Dim x1 As Integer
Dim x2 As Integer
Dim strNewField As String
On Error GoTo HandleIt
'get table/field definitions
Set CurDB = DBEngine(0)(0)
Set rstTbls = CurDB.OpenRecordset("abfTempTableNames", dbOpenSnapshot)
'get current path and set DB name from constant
strNewDB = Mid(CurDB.Name, 1, Len(CurDB.Name) - 4) & "_tmp" & right(CurDB.Name,
4)
' Get default Workspace.
Set BFws = DBEngine.Workspaces(0)
' Make sure there isn't already a file with the name of
' the new database.
If Dir(strNewDB) <"" Then Kill strNewDB
' Create a new database
Set Bfdb = BFws.CreateDatabase(strNewDB, dbLangGeneral)
'create tables
With rstTbls
If Not (.BOF And .EOF) Then
'set status line
varRet = SysCmd(acSysCmdSetStatus, "Now Creating Temporary File.")
Do Until .EOF
'add tabledef
Set tdf = Bfdb.CreateTableDef(!TempTableName)
'add fields
strSQL = "SELECT * FROM abfTempTableFieldNames WHERE
(((TempTableName)='" & !TempTableName & "'));"
Set rstFlds = CurDB.OpenRecordset(strSQL, dbOpenSnapshot)
With rstFlds
If Not (.BOF And .EOF) Then
Do Until .EOF
Set fldNew = tdf.CreateField(!FieldName, !FieldType,
!FieldSize)
If !AutoNum = True Then
fldNew.Attributes = dbAutoIncrField
End If
tdf.Fields.Append fldNew
.MoveNext
Loop
End If
.Close
End With
Set rstFlds = Nothing
'add indexes
strSQL = "SELECT * FROM abfTempTableIndexes WHERE
(((TempTableName)='" & !TempTableName & "'));"
Set rstInds = CurDB.OpenRecordset(strSQL, dbOpenSnapshot)
With rstInds
If Not (.BOF And .EOF) Then
Do Until .EOF
'create index
Set indNew = tdf.CreateIndex(!Name)
indNew.IgnoreNulls = !IgnoreNulls
indNew.Primary = !Primary
indNew.Required = !Required
indNew.Unique = !Unique
'parse Fields property and strip individual field names
'append each field to index fields collection
strFields = rstInds!Fields
Do Until InStr(1, strFields, Chr(43)) = 0
x1 = InStr(1, strFields, Chr(43))
x2 = InStr(2, strFields, Chr(43))
If x2 <0 Then
strNewField = Mid(strFields, x1 + 1, ((x2 - 1) -
(x1 + 1)))
strFields = right(strFields, Len(strFields) -
(x2 - 1))
indNew.Fields.Append
indNew.CreateField(strNewField)
Else
strNewField = right(strFields, Len(strFields) -
1)
strFields = ""
indNew.Fields.Append
indNew.CreateField(strNewField)
End If
Loop
tdf.Indexes.Append indNew
.MoveNext
Loop
End If
.Close
End With
Set rstInds = Nothing
Bfdb.TableDefs.Append tdf
'link table
CurDB.TableDefs.Refresh
If (fCheckLink(tdf.Name)) Then 'already linked so delete and
refresh
Set tdfNew = CurDB.TableDefs(tdf.Name)
CurDB.TableDefs.Delete tdfNew.Name
CurDB.TableDefs.Refresh
Set tdfNew = CurDB.CreateTableDef(tdf.Name)
tdfNew.Connect = ";Database=" & Bfdb.Name
tdfNew.SourceTableName = tdf.Name
CurDB.TableDefs.Append tdfNew
tdfNew.RefreshLink
Else
'connect here
Set tdfNew = CurDB.CreateTableDef(tdf.Name)
tdfNew.Connect = ";Database=" & Bfdb.Name
tdfNew.SourceTableName = tdf.Name
CurDB.TableDefs.Append tdfNew
tdfNew.RefreshLink
End If
.MoveNext
Loop
End If
End With
'success
fCreateTempDB = True
OutHere:
varRet = SysCmd(acSysCmdClearStatus)
Bfdb.Close
Set Bfdb = Nothing
Set BFws = Nothing
Set CurDB = Nothing
Exit Function
HandleIt:
Select Case Err
Case 0, 91
Resume Next
Case 75
fCreateTempDB = False
Resume OutHere
Case Else
Beep
MsgBox Err & " " & Err.Description, vbCritical + vbOKOnly,
"fCreateTempDB"
fCreateTempDB = False
Resume OutHere
End Select
End Function
'************************************************* ********************
Function fCheckLink(strTableName As String) As Boolean
'check if passed table name exists in DB
Dim i As Integer
Dim Bfdb As Database
On Error GoTo HandleIt
Set Bfdb = DBEngine(0)(0)
Bfdb.TableDefs.Refresh
fCheckLink = False
For i = 0 To Bfdb.TableDefs.Count - 1
If Bfdb.TableDefs(i).Name = strTableName Then
fCheckLink = True
Exit For
End If
Next i
OutHere:
Set Bfdb = Nothing
Exit Function
HandleIt:
Select Case Err
Case Else
fCheckLink = False
Resume OutHere
End Select
End Function
'************************************************* ********************
Wayne Gillespie
Gosford NSW Australia
