|
Two ways to create a new database containing the same tables as a template database. Insert the following code into an Access 97/2000/2003/2007 module.
Function CloneTableDefs(ByVal strTemplateDatabase As String, ByVal strNewDatabase As String)
On Error Resume Next
Dim myDB As Database
Dim myTDF As TableDef
Dim myField As Field
Dim myIndex As Index
Dim lngTDFCount As Long
Dim TDFs As TableDefs
Dim a As Long, b As Long, c As Long
Dim lngFieldCount As Long
Dim lngIndexCount As Long
Dim lngPropCount As Long
Dim myProperty As Property
Dim TemplateDB As Database
Set myDB = DAO.DBEngine.CreateDatabase(strNewDatabase, dbLangGeneral, dbVersion30)
Set TemplateDB = DAO.DBEngine.OpenDatabase(strTemplateDatabase, , True)
Set TDFs = TemplateDB.TableDefs
lngTDFCount = TDFs.Count - 1
For a = 0 To lngTDFCount
If (TDFs(a).Attributes And dbSystemObject) = False And (TDFs(a).Attributes And dbHiddenObject) = False And (TDFs(a).Attributes And 2) = False Then
Set myTDF = myDB.CreateTableDef(TDFs(a).Name)
lngFieldCount = TDFs(a).Fields.Count - 1
For b = 0 To lngFieldCount
Set myField = myTDF.CreateField(TDFs(a).Fields(b).Name, TDFs(a).Fields(b).Type)
lngPropCount = TDFs(a).Fields(b).Properties.Count - 1
For c = 0 To lngPropCount
Err.Clear
myField.Properties(TDFs(a).Fields(b).Properties(c).Name).Value = TDFs(a).Fields(b).Properties(c).Value
If Err.Number <> 0 Then
Err.Clear
Set myProperty = myField.CreateProperty(TDFs(a).Fields(b).Properties(c).Name, TDFs(a).Fields(b).Properties(c).Type, TDFs(a).Fields(b).Properties(c))
myField.Properties.Append myProperty
End If
Next c
myTDF.Fields.Append myField
Next b
Err.Clear
lngIndexCount = TDFs(a).Indexes.Count - 1
For b = 0 To lngIndexCount
Set myIndex = myTDF.CreateIndex(TDFs(a).Indexes(b).Name)
lngPropCount = TDFs(a).Indexes(b).Properties.Count - 1
For c = 0 To lngPropCount
myIndex.Properties(TDFs(a).Indexes(b).Properties(c).Name) = TDFs(a).Indexes(b).Properties(c)
Err.Clear
Next c
lngFieldCount = TDFs(a).Indexes(b).Fields.Count - 1
For c = 0 To lngFieldCount
Set myField = myIndex.CreateField(TDFs(a).Indexes(b).Fields(c).Name)
Err.Clear
Next c
myIndex.Fields.Append myField
myTDF.Indexes.Append myIndex
Next b
myDB.TableDefs.Append myTDF
End If
Next a
myDB.Close
Set myDB = Nothing
End Function
Function CreateDBCreateFunction(ByVal strModuleName As String, ByVal strFunctionName As String, ByVal strTemplateDatabase As String)
On Error Resume Next
Dim myDB As Database
Dim lngTDFCount As Long
Dim TDFs As TableDefs
Dim a As Long, b As Long, c As Long
Dim lngFieldCount As Long
Dim lngIndexCount As Long
Dim lngPropCount As Long
Dim myProperty As Property
Dim strTempFolder As String
Dim strData As String
Dim strTableArray() As String
Dim lngCount As Long
Dim TemplateDatabase As Database
Dim strTemp As String
strTempFolder = Environ$("TEMP")
If Dir$(strTempFolder, vbDirectory) = "" Then
strTempFolder = "C:"
End If
strTempFolder = strTempFolder & "\"
Kill strTempFolder & strModuleName
Open strTempFolder & strModuleName For Binary As #1
strData = "Option Explicit" & vbCrLf & "Option Compare Database" & vbCrLf
Put 1, , strData
strData = "Public myDB As Database" & vbCrLf
Put 1, , strData
' Function AppendProperty()
strData = vbCrLf
Put 1, , strData
strData = "Private Function AppendProperty(ByRef myField As Field, ByVal strPropertyName as String, ByVal lngPropertyType as long, ByVal strPropertyValue as string)" & vbCrLf
Put 1, , strData
strData = vbTab & "Dim myProperty as Property" & vbCrLf
Put 1, , strData
strData = vbTab & "On Error Resume Next" & vbCrLf
Put 1, , strData
strData = vbTab & "myField.Properties(strPropertyName).Value = strPropertyValue" & vbCrLf
Put 1, , strData
strData = vbTab & "If Err.Number <> 0 Then" & vbCrLf & _
vbTab & vbTab & "Err.Clear" & vbCrLf & _
vbTab & vbTab & "Set myProperty = myField.CreateProperty(strPropertyName, lngPropertyType, strPropertyValue)" & vbCrLf & _
vbTab & vbTab & "myField.Properties.Append myProperty" & vbCrLf & _
vbTab & "End If" & vbCrLf
Put 1, , strData
strData = "End Function" & vbCrLf
Put 1, , strData
Set TemplateDatabase = DAO.DBEngine.OpenDatabase(strTemplateDatabase, , True)
Set TDFs = TemplateDatabase.TableDefs
lngTDFCount = TDFs.Count - 1
For a = 0 To lngTDFCount
If (TDFs(a).Attributes And dbSystemObject) = False And (TDFs(a).Attributes And dbHiddenObject) = False And (TDFs(a).Attributes And 2) = False Then
ReDim Preserve strTableArray(lngCount)
strTableArray(lngCount) = "Fun" & lngCount
strData = vbCrLf
Put 1, , strData
strData = "Private Function fun" & strTableArray(lngCount) & "()" & vbCrLf
Put 1, , strData
strData = vbTab & "On Error Resume Next" & vbCrLf
Put 1, , strData
strData = vbTab & "Dim myTDF As TableDef" & vbCrLf
Put 1, , strData
strData = vbTab & "Dim myField As Field" & vbCrLf
Put 1, , strData
strData = vbTab & "Dim myIndex As Index" & vbCrLf
Put 1, , strData
strData = vbTab & "Set myTDF = myDB.CreateTableDef(" & Chr$(34) & TDFs(a).Name & Chr$(34) & ")" & vbCrLf
Put 1, , strData
lngFieldCount = TDFs(a).Fields.Count - 1
For b = 0 To lngFieldCount
strData = vbTab & vbTab & "Set myField = myTDF.CreateField(" & Chr$(34) & TDFs(a).Fields(b).Name & Chr$(34) & ", " & TDFs(a).Fields(b).Type & ")" & vbCrLf
Put 1, , strData
lngPropCount = TDFs(a).Fields(b).Properties.Count - 1
For c = 0 To lngPropCount
Err.Clear
strTemp = ""
strTemp = RemoveQuotes(TDFs(a).Fields(b).Properties(c).Value)
If strTemp <> "" Then
If TDFs(a).Fields(b).Properties(c).Type = dbText Or TDFs(a).Fields(b).Properties(c).Type = dbMemo Then
strData = vbTab & vbTab & vbTab & "AppendProperty myField, " & Chr$(34) & TDFs(a).Fields(b).Properties(c).Name & Chr$(34) & ", " & TDFs(a).Fields(b).Properties(c).Type & ", " & Chr$(34) & strTemp & Chr$(34) & vbCrLf
Else
strData = vbTab & vbTab & vbTab & "AppendProperty myField, " & Chr$(34) & TDFs(a).Fields(b).Properties(c).Name & Chr$(34) & ", " & TDFs(a).Fields(b).Properties(c).Type & ", " & strTemp & vbCrLf
End If
Put 1, , strData
End If
Next c
strData = vbTab & vbTab & "myTDF.Fields.Append myField" & vbCrLf
Put 1, , strData
Next b
Err.Clear
lngIndexCount = TDFs(a).Indexes.Count - 1
For b = 0 To lngIndexCount
strData = vbTab & vbTab & "Set myIndex = myTDF.CreateIndex(" & Chr$(34) & TDFs(a).Indexes(b).Name & Chr$(34) & ")" & vbCrLf
Put 1, , strData
lngPropCount = TDFs(a).Indexes(b).Properties.Count - 1
For c = 0 To lngPropCount
strTemp = ""
strTemp = RemoveQuotes(TDFs(a).Indexes(b).Properties(c))
If strTemp <> "" Then
If TDFs(a).Indexes(b).Properties(c).Type = dbText Or TDFs(a).Indexes(b).Properties(c).Type = dbMemo Then
strData = vbTab & vbTab & vbTab & "myIndex.Properties(" & Chr$(34) & TDFs(a).Indexes(b).Properties(c).Name & Chr$(34) & ") = " & Chr$(34) & strTemp & Chr$(34) & vbCrLf & vbTab & vbTab & vbTab & "Err.Clear" & vbCrLf
Else
strData = vbTab & vbTab & vbTab & "myIndex.Properties(" & Chr$(34) & TDFs(a).Indexes(b).Properties(c).Name & Chr$(34) & ") = " & strTemp & vbCrLf & vbTab & vbTab & vbTab & "Err.Clear" & vbCrLf
End If
Put 1, , strData
End If
Next c
lngFieldCount = TDFs(a).Indexes(b).Fields.Count - 1
For c = 0 To lngFieldCount
strData = vbTab & vbTab & "Set myField = myIndex.CreateField(" & Chr$(34) & TDFs(a).Indexes(b).Fields(c).Name & Chr$(34) & ")" & vbCrLf & _
vbTab & vbTab & "Err.Clear" & vbCrLf
Put 1, , strData
strData = vbTab & vbTab & "myIndex.Fields.Append myField" & vbCrLf
Put 1, , strData
Next c
strData = vbTab & vbTab & "myTDF.Indexes.Append myIndex" & vbCrLf
Put 1, , strData
Next b
strData = vbTab & "myDB.TableDefs.Append myTDF" & vbCrLf
Put 1, , strData
strData = "End Function" & vbCrLf
Put 1, , strData
lngCount = lngCount + 1
End If
Next a
myDB.Close
Set myDB = Nothing
lngCount = lngCount - 1
'Main Function
strData = "Function " & strFunctionName & "(ByVal strDBName As String)" & vbCrLf
Put 1, , strData
strData = vbTab & "Set myDB = DAO.DBEngine.CreateDatabase(strDBName, dbLangGeneral, dbVersion30)" & vbCrLf
Put 1, , strData
strData = vbTab & "Access.SysCmd AcSysCmdInitMeter," & Chr$(34) & "Creating " & Chr$(34) & " & strDBName & " & Chr$(34) & ":" & Chr$(34) & ", " & CStr(lngCount + 1) & vbCrLf
Put 1, , strData
For a = 0 To lngCount
strData = vbTab & "Access.SysCmd AcSysCmdUpdateMeter, " & CStr(a + 1) & vbCrLf
Put 1, , strData
strData = vbTab & "fun" & strTableArray(a) & vbCrLf
Put 1, , strData
Next a
strData = vbTab & "Access.SysCmd AcSysCmdRemoveMeter" & vbCrLf
Put 1, , strData
strData = vbTab & "myDB.Close" & vbCrLf & vbTab & "Set myDB = Nothing" & vbCrLf
Put 1, , strData
strData = "End Function" & vbCrLf
Put 1, , strData
Close 1
MSAccess.LoadFromText acModule, strModuleName, strTempFolder & strModuleName
End Function
By downloading this code, you agree to use it solely at your own risk. I provide no warranty express or implied for this code.
I can be reached via email to mvernon@mvct.ca. If I don't reply it's because either my spam filter took care of you, or I'm really busy. Either way, please accept my apologies in advance.
|
