paulstamp
asked on
Scripting Jet Databases
I currently have an app which ships with a template database (ie structure set up but no data) which gets copied when a user creates a new project. I'd rather not ship this additional database in the install routine - I'd like to do it in code.
I know with SQL-server you can use scripts to generate databases "on the fly". Does anyone know of an easy way to achieve this for Access databases ? An example would be appreciated (doesnt have to be complete - just a pointer will do).
I know for a complex database this will mean a lot of code, so if anyone knows of an add-in or utility that helps that would be handy.
I know with SQL-server you can use scripts to generate databases "on the fly". Does anyone know of an easy way to achieve this for Access databases ? An example would be appreciated (doesnt have to be complete - just a pointer will do).
I know for a complex database this will mean a lot of code, so if anyone knows of an add-in or utility that helps that would be handy.
It would be better to ship the template, however
you can use DAO (Data Access Objects) to create new databases.
I've got an example of that somewhere, I'll look it out for you
Gordon
you can use DAO (Data Access Objects) to create new databases.
I've got an example of that somewhere, I'll look it out for you
Gordon
Forget my code, its an old project and unreadable.
HEres a guide
Dim gDatabase as Database
Set gDatabase = CreateDatabase(<Filepath>)
Dim oTable as TableDEf
Set oTable = gDatabase.CreateTableDef(< Table Name>")
Dim oField as Field
set oField = oTable.CreateField(<Field Name>,<Type>,<Size>)
oTable.Fields.Append oField
gDatabase.TableDefs.Append oTable
there are other functions for adding Queries, Relationships, Database properties.
The help files for DAO are pretty decent so have a look through the various objects and methods there.
Hope this all helps
Gordon
HEres a guide
Dim gDatabase as Database
Set gDatabase = CreateDatabase(<Filepath>)
Dim oTable as TableDEf
Set oTable = gDatabase.CreateTableDef(<
Dim oField as Field
set oField = oTable.CreateField(<Field Name>,<Type>,<Size>)
oTable.Fields.Append oField
gDatabase.TableDefs.Append
there are other functions for adding Queries, Relationships, Database properties.
The help files for DAO are pretty decent so have a look through the various objects and methods there.
Hope this all helps
Gordon
Perhaps using the package possibility is useful. If you have the developer version of access you can package an application with all necessary modules. Can't you do this from the VB developer?
<Does anyone know of an easy way to achieve this for Access databases ?
Yes. This procedure is what you are looking for:
Option Explicit
Dim FielDescript() As String
Dim DescrptCount As Integer
Dim TabDescript As String
Dim DBName As String
Dim NewBase As String
Dim OldBase As String
Dim TabNam As String
Dim FlNam As String
Dim IdxNam As String
Dim RelNam As String
Dim QDefNam As String
Dim sql As String
Dim Idx As Index, Rel As Relation
Dim pr As Property
Dim NewPr As Property
Dim WS As Workspace
Dim Db As Database
Dim Td As TableDef
Dim fl As Field
Dim Fld As Field
Dim Qd As QueryDef
Dim Qdef As QueryDef
Dim NewQDef As QueryDef
Dim NewTab As TableDef
Dim NewDB As Database
Dim NewField As Field
Dim NewIdx As Index
Dim tmpField As Field
Dim NewRl As Relation
Sub Main()
On Error Resume Next
Dim str As String, n As Integer
str = Command()
If str = "" Or str = "?" Then
MsgBox "Command Line parameters:" & Chr(13) & _
"MakeMap.exe MyDB.mdb NewDB.mdb"
GoTo EndProg
End If
n = InStr(Trim(str), " ")
If n > 0 Then
OldBase = Left(str, n - 1)
NewBase = Mid(str, n + 1)
Else
OldBase = str
NewBase = Left(str, InStr(Trim(str), ".") - 1) & "New" & ".mdb"
End If
If Dir("MakeDB.bas") <> "" Then Kill ("MakeDB.bas")
Open "MakeDB.bas" For Append As 1
Set WS = DBEngine.Workspaces(0)
Set Db = WS.OpenDatabase(OldBase)
If Err.Number = 3031 Then
Dim passw As String
Err.Clear
passw = InputBox("Enter the password")
passw = ";pwd=" & passw
Set Db = WS.OpenDatabase(OldBase, 0, False, passw)
If Err.Number = 3031 Then MsgBox "Password Error!": GoTo EndProg
End If
Begin
Db.Close
NewDB.Close
WS.Close
Set WS = Nothing
Set Db = Nothing
Set NewField = Nothing
Set NewIdx = Nothing
Set NewQDef = Nothing
Set NewRl = Nothing
Set NewTab = Nothing
Set tmpField = Nothing
Set Td = Nothing
Set fl = Nothing
Set Fld = Nothing
Set Qd = Nothing
Set Rel = Nothing
Set Idx = Nothing
EndProg:
Reset
End
End Sub
Private Sub Begin()
On Error GoTo ErrH
CreateDB NewBase
'generate BAS module
MakeHead
Print #1, "'********************* Generate DataBase ************************** **"; Chr(13)
Print #1, "Public Function CreateNewDataBase ()"
Print #1, "On Error resume next"
Print #1, "DBName="; Chr(34); NewBase; Chr(34)
Print #1, "Set NewDB = DBEngine.Workspaces(0).Cre ateDatabas e(DBName, dbLangCyrillic, dbVersion30)"
For Each Td In Db.TableDefs
TabNam = Td.Name
If Left(TabNam, 4) = "MSys" Then GoTo EndCyc
Print #1, "'**************** Generate TableDef ************************** "
Print #1, "'---------------- "; TabNam; " -------------------------- -----"
CreateTab TabNam
For Each pr In Td.Properties
If pr.Name = "Description" Then
Print #1, "'"; pr.Value
Print #1, "TabDescript = "; Chr(34); pr.Value; Chr(34)
TabDescript = pr.Value
End If
Next
Print #1, "TabName = "; Chr(34); TabNam; Chr(34)
Print #1, "Set NewTab = NewDb.CreateTableDef(TabNa me)"
Print #1, "'----------------- Fields -------------------------- -"
DescrptCount = 0
Print #1, "DescrCount = 0"
For Each Fld In Td.Fields
ReDim Preserve FielDescript(DescrptCount + 1)
Print #1, "ReDim Preserve FielDescript(DescrCount + 1)"
FlNam = Fld.Name
CreateField Fld.Name, Fld.Type, Fld.Size, Fld.Attributes
Set Fld = Td.Fields(FlNam)
For Each pr In Fld.Properties
If pr.Name = "Description" Then
Print #1, "'"; pr.Value
Print #1, "FielDescript(DescrCount) = "; Chr(34); pr.Value; Chr(34)
FielDescript(DescrptCount) = pr.Value
End If
Next
DescrptCount = DescrptCount + 1
Print #1, "DescrCount = DescrCount + 1"
Print #1, "FieldName ="; Chr(34); Fld.Name; Chr(34)
Print #1, "Set NewField = NewTab.CreateField(Fieldna me," & ShowType(Fld.Type) & "," & Fld.Size & ")"
Print #1, "NewField.Attributes = " & Fld.Attributes
NewTab.Fields.Append NewField
Print #1, "NewTab.Fields.Append NewField"
Next
NewDB.TableDefs.Append NewTab
CreateProperty TabDescript
TabDescript = ""
CreateFieldProperty
Print #1, "NewDB.TableDefs.Append NewTab"
Print #1, "If Trim(TabDescript) <> "; Chr(34); ; Chr(34); " Then _"
Print #1, "Set NewPr = NewTab.CreateProperty("; Chr(34); "Description"; Chr(34); ", dbText, TabDescript): _"
Print #1, "NewTab.Properties.Append NewPr"
Print #1, "DescrCount = 0"
Print #1, "TabDescript = "; Chr(34); Chr(34)
Print #1, "For Each NewField In NewTab.Fields"
Print #1, " If Trim(FielDescript(DescrCou nt)) = "; Chr(34); ; Chr(34); " Then GoTo Metka"; NewTab.Name
Print #1, " Set NewPr = NewField.CreateProperty("; Chr(34); "Description"; Chr(34); ", dbText, FielDescript(DescrCount))"
Print #1, " NewField.Properties.Append NewPr"
Print #1, "Metka"; NewTab.Name; ":"
Print #1, " DescrCount = DescrCount + 1"
Print #1, "Next"
Print #1, "Erase FielDescript"
Print #1, "'------------------ Index -------------------------- ----"
For Each Idx In Td.Indexes
CreateIdx Idx.Name
IdxNam = Idx.Name
Print #1, "IdxName = "; Chr(34); IdxNam; Chr(34)
Print #1, "Set NewIdx = NewTab.CreateIndex(IdxName )"
Print #1, "NewIdx.Primary = " & Idx.Primary
Print #1, "NewIdx.Unique = " & Idx.Unique
For Each Fld In Idx.Fields
AddFieldInIdx Fld.Name
Print #1, "IdxName = "; Chr(34); Fld.Name; Chr(34)
Print #1, "Set tmpField = NewIdx.CreateField(IdxName )"
Next
NewIdx.Fields.Append tmpField
Print #1, "NewIdx.Fields.Append tmpField"
NewTab.Indexes.Append NewIdx
Print #1, "NewTab.Indexes.Append NewIdx"
Next
EndCyc:
Next
Print #1, Chr(13)
Print #1, "'**************** Generate Relations ***********************"
For Each Rel In Db.Relations
For Each fl In Rel.Fields
Print #1, "'------------------------ ---------- --------"
Print #1, "RelName ="; Chr(34); Rel.Name; "_"; Rel.Table; Chr(34)
CreateRl Rel.Name & "_" & Rel.Table, fl.Name, fl.ForeignName
Print #1, "Set NewRl = NewDB.CreateRelation(RelNa me)"
Print #1, "NewRl.Table ="; Chr(34); Rel.Table; Chr(34)
Print #1, "NewRl.ForeignTable = "; Chr(34); Rel.ForeignTable; Chr(34)
Print #1, "Set NewField = NewRl.CreateField("; Chr(34); fl.Name; Chr(34); ")"
Print #1, "NewField.ForeignName ="; Chr(34); fl.ForeignName; Chr(34)
Print #1, "NewRl.Fields.Append NewField"
Print #1, "NewRl.Attributes = dbRelationUpdateCascade"
Print #1, "NewDB.Relations.Append NewRl"
Next
Next
Print #1, Chr(13)
Print #1, "'**************** Generate QueryDef ***********************"
Dim tmp As Integer
For Each Qd In Db.QueryDefs
QDefNam = Qd.Name
sql = Qd.sql
Print #1, "'------------------------ ---------- --------"
Print #1, "QDefName = "; Chr(34); QDefNam; Chr(34)
'hga`bhlq nr <Enter>
Do While InStr(sql, Chr(13)) <> 0
tmp = InStr(sql, Chr(13))
sql = Left(sql, tmp - 1) & " " & Mid(sql, tmp + 2)
Loop
'g`lemhl 2-j`b{wjs m` ndhm`pms~
Do While InStr(sql, Chr(34)) <> 0
tmp = InStr(sql, Chr(34))
sql = Left(sql, tmp - 1) & "'" & Mid(sql, tmp + 1)
Loop
CreateQD QDefNam
Print #1, "sql = "; Chr(34); sql; Chr(34)
Print #1, "Set NewQDef = NewDB.CreateQueryDef(QDefN ame, sql)"
Next
Print #1, "'************************ END ************************** ********** *"; Chr(13)
Print #1, "NewDB.Close"
Print #1, "Set NewTab = Nothing"
Print #1, "Set NewIdx = Nothing"
Print #1, "Set tmpField = Nothing"
Print #1, "Set NewRl = Nothing"
Print #1, "Set NewQDef = Nothing"
Print #1, "Set NewDB = Nothing"
Print #1, "CreateNewDataBase=Err.Num ber"
Print #1, "End Function"
Exit Sub
ErrH:
Print #1, Err.Description
Resume Next
End Sub
Sub CreateQD(mName As String)
Set NewQDef = NewDB.CreateQueryDef(mName , Qd.sql)
End Sub
Sub CreateRl(mName, nam As String, fnam As String)
Set NewRl = NewDB.CreateRelation(mName )
NewRl.Table = Rel.Table
NewRl.ForeignTable = Rel.ForeignTable
Set NewField = NewRl.CreateField(nam)
NewField.ForeignName = fnam
NewRl.Fields.Append NewField
NewRl.Attributes = dbRelationUpdateCascade
NewDB.Relations.Append NewRl
End Sub
Private Sub CreateDB(mName As String)
Dim q As String
q = Dir(mName)
If Dir(mName) <> "" Then Kill (mName)
Set NewDB = WS.CreateDatabase(mName, dbLangCyrillic, dbVersion30)
End Sub
Private Sub CreateTab(mName As String)
Set NewTab = Db.CreateTableDef(mName)
End Sub
Private Sub CreateField(mName As String, mType As Long, mSize As Long, Optional mAtr As Long)
Set NewField = NewTab.CreateField(mName, mType, mSize)
NewField.Attributes = mAtr
End Sub
Private Sub CreateFieldProperty()
DescrptCount = 0
For Each fl In NewTab.Fields
If Trim(FielDescript(DescrptC ount)) = "" Then GoTo M0
Set NewPr = fl.CreateProperty("Descrip tion", dbText, FielDescript(DescrptCount) )
fl.Properties.Append NewPr
M0:
DescrptCount = DescrptCount + 1
Next
Erase FielDescript
End Sub
Private Sub CreateProperty(mVal As String)
If Trim(mVal) = "" Then Exit Sub
Set NewPr = NewTab.CreateProperty("Des cription", dbText, mVal)
NewTab.Properties.Append NewPr
End Sub
Private Sub CreateIdx(mIdx As String)
Set NewIdx = NewTab.CreateIndex(mIdx)
NewIdx.Primary = Idx.Primary
NewIdx.Unique = Idx.Unique
End Sub
Private Sub AddFieldInIdx(mNameField As String)
Set tmpField = NewIdx.CreateField(mNameFi eld)
End Sub
Private Function ShowType(varTypeCode As Variant) As String
Dim strRet As String
Select Case varTypeCode
Case dbInteger
strRet = "dbInteger"
Case dbLong
strRet = "dbLong"
Case dbSingle
strRet = "dbSingle"
Case dbDouble
strRet = "dbCurrency"
Case dbCurrency
strRet = "dbCurrency"
Case dbDate
strRet = "dbDate"
Case dbText
strRet = "dbText"
Case dbBoolean
strRet = "dbBoolean"
Case dbDecimal
strRet = "dbDecimal"
Case dbByte
strRet = "dbByte"
Case Else
strRet = "[ " & CStr(varTypeCode) & " ]"
End Select
ShowType = strRet
End Function
Sub MakeHead()
Print #1, "'Module:"; vbTab; "MakeDB.bas"
Print #1, "'Description:"; vbTab; "Create *.mdb file"
Print #1, "'Date:"; vbTab; vbTab; Now; Chr(13)
Print #1, "Dim NewTab As TableDef"
Print #1, "Dim NewDB As Database"
Print #1, "Dim NewField As Field"
Print #1, "Dim NewIdx As Index"
Print #1, "Dim tmpField As Field"
Print #1, "Dim NewRl As Relation"
Print #1, "Dim NewQDef As QueryDef"
Print #1, "Dim TabName as String"
Print #1, "Dim FieldName as String"
Print #1, "Dim IdxName as String"
Print #1, "Dim RelatName as String"
Print #1, "Dim QDefName as String"
Print #1, "Dim sql as String"
Print #1, "Dim DBName as String"
Print #1, "Dim TabDescript as String"
Print #1, "Dim FielDescript() as String"
Print #1, "Dim DescrCount as Integer"
Print #1, "'------------------------ ---------- ---------- ---------- ---"; Chr(13)
End Sub
HTH
Yes. This procedure is what you are looking for:
Option Explicit
Dim FielDescript() As String
Dim DescrptCount As Integer
Dim TabDescript As String
Dim DBName As String
Dim NewBase As String
Dim OldBase As String
Dim TabNam As String
Dim FlNam As String
Dim IdxNam As String
Dim RelNam As String
Dim QDefNam As String
Dim sql As String
Dim Idx As Index, Rel As Relation
Dim pr As Property
Dim NewPr As Property
Dim WS As Workspace
Dim Db As Database
Dim Td As TableDef
Dim fl As Field
Dim Fld As Field
Dim Qd As QueryDef
Dim Qdef As QueryDef
Dim NewQDef As QueryDef
Dim NewTab As TableDef
Dim NewDB As Database
Dim NewField As Field
Dim NewIdx As Index
Dim tmpField As Field
Dim NewRl As Relation
Sub Main()
On Error Resume Next
Dim str As String, n As Integer
str = Command()
If str = "" Or str = "?" Then
MsgBox "Command Line parameters:" & Chr(13) & _
"MakeMap.exe MyDB.mdb NewDB.mdb"
GoTo EndProg
End If
n = InStr(Trim(str), " ")
If n > 0 Then
OldBase = Left(str, n - 1)
NewBase = Mid(str, n + 1)
Else
OldBase = str
NewBase = Left(str, InStr(Trim(str), ".") - 1) & "New" & ".mdb"
End If
If Dir("MakeDB.bas") <> "" Then Kill ("MakeDB.bas")
Open "MakeDB.bas" For Append As 1
Set WS = DBEngine.Workspaces(0)
Set Db = WS.OpenDatabase(OldBase)
If Err.Number = 3031 Then
Dim passw As String
Err.Clear
passw = InputBox("Enter the password")
passw = ";pwd=" & passw
Set Db = WS.OpenDatabase(OldBase, 0, False, passw)
If Err.Number = 3031 Then MsgBox "Password Error!": GoTo EndProg
End If
Begin
Db.Close
NewDB.Close
WS.Close
Set WS = Nothing
Set Db = Nothing
Set NewField = Nothing
Set NewIdx = Nothing
Set NewQDef = Nothing
Set NewRl = Nothing
Set NewTab = Nothing
Set tmpField = Nothing
Set Td = Nothing
Set fl = Nothing
Set Fld = Nothing
Set Qd = Nothing
Set Rel = Nothing
Set Idx = Nothing
EndProg:
Reset
End
End Sub
Private Sub Begin()
On Error GoTo ErrH
CreateDB NewBase
'generate BAS module
MakeHead
Print #1, "'********************* Generate DataBase **************************
Print #1, "Public Function CreateNewDataBase ()"
Print #1, "On Error resume next"
Print #1, "DBName="; Chr(34); NewBase; Chr(34)
Print #1, "Set NewDB = DBEngine.Workspaces(0).Cre
For Each Td In Db.TableDefs
TabNam = Td.Name
If Left(TabNam, 4) = "MSys" Then GoTo EndCyc
Print #1, "'**************** Generate TableDef **************************
Print #1, "'---------------- "; TabNam; " --------------------------
CreateTab TabNam
For Each pr In Td.Properties
If pr.Name = "Description" Then
Print #1, "'"; pr.Value
Print #1, "TabDescript = "; Chr(34); pr.Value; Chr(34)
TabDescript = pr.Value
End If
Next
Print #1, "TabName = "; Chr(34); TabNam; Chr(34)
Print #1, "Set NewTab = NewDb.CreateTableDef(TabNa
Print #1, "'----------------- Fields --------------------------
DescrptCount = 0
Print #1, "DescrCount = 0"
For Each Fld In Td.Fields
ReDim Preserve FielDescript(DescrptCount + 1)
Print #1, "ReDim Preserve FielDescript(DescrCount + 1)"
FlNam = Fld.Name
CreateField Fld.Name, Fld.Type, Fld.Size, Fld.Attributes
Set Fld = Td.Fields(FlNam)
For Each pr In Fld.Properties
If pr.Name = "Description" Then
Print #1, "'"; pr.Value
Print #1, "FielDescript(DescrCount) = "; Chr(34); pr.Value; Chr(34)
FielDescript(DescrptCount)
End If
Next
DescrptCount = DescrptCount + 1
Print #1, "DescrCount = DescrCount + 1"
Print #1, "FieldName ="; Chr(34); Fld.Name; Chr(34)
Print #1, "Set NewField = NewTab.CreateField(Fieldna
Print #1, "NewField.Attributes = " & Fld.Attributes
NewTab.Fields.Append NewField
Print #1, "NewTab.Fields.Append NewField"
Next
NewDB.TableDefs.Append NewTab
CreateProperty TabDescript
TabDescript = ""
CreateFieldProperty
Print #1, "NewDB.TableDefs.Append NewTab"
Print #1, "If Trim(TabDescript) <> "; Chr(34); ; Chr(34); " Then _"
Print #1, "Set NewPr = NewTab.CreateProperty("; Chr(34); "Description"; Chr(34); ", dbText, TabDescript): _"
Print #1, "NewTab.Properties.Append NewPr"
Print #1, "DescrCount = 0"
Print #1, "TabDescript = "; Chr(34); Chr(34)
Print #1, "For Each NewField In NewTab.Fields"
Print #1, " If Trim(FielDescript(DescrCou
Print #1, " Set NewPr = NewField.CreateProperty(";
Print #1, " NewField.Properties.Append
Print #1, "Metka"; NewTab.Name; ":"
Print #1, " DescrCount = DescrCount + 1"
Print #1, "Next"
Print #1, "Erase FielDescript"
Print #1, "'------------------ Index --------------------------
For Each Idx In Td.Indexes
CreateIdx Idx.Name
IdxNam = Idx.Name
Print #1, "IdxName = "; Chr(34); IdxNam; Chr(34)
Print #1, "Set NewIdx = NewTab.CreateIndex(IdxName
Print #1, "NewIdx.Primary = " & Idx.Primary
Print #1, "NewIdx.Unique = " & Idx.Unique
For Each Fld In Idx.Fields
AddFieldInIdx Fld.Name
Print #1, "IdxName = "; Chr(34); Fld.Name; Chr(34)
Print #1, "Set tmpField = NewIdx.CreateField(IdxName
Next
NewIdx.Fields.Append tmpField
Print #1, "NewIdx.Fields.Append tmpField"
NewTab.Indexes.Append NewIdx
Print #1, "NewTab.Indexes.Append NewIdx"
Next
EndCyc:
Next
Print #1, Chr(13)
Print #1, "'**************** Generate Relations ***********************"
For Each Rel In Db.Relations
For Each fl In Rel.Fields
Print #1, "'------------------------
Print #1, "RelName ="; Chr(34); Rel.Name; "_"; Rel.Table; Chr(34)
CreateRl Rel.Name & "_" & Rel.Table, fl.Name, fl.ForeignName
Print #1, "Set NewRl = NewDB.CreateRelation(RelNa
Print #1, "NewRl.Table ="; Chr(34); Rel.Table; Chr(34)
Print #1, "NewRl.ForeignTable = "; Chr(34); Rel.ForeignTable; Chr(34)
Print #1, "Set NewField = NewRl.CreateField("; Chr(34); fl.Name; Chr(34); ")"
Print #1, "NewField.ForeignName ="; Chr(34); fl.ForeignName; Chr(34)
Print #1, "NewRl.Fields.Append NewField"
Print #1, "NewRl.Attributes = dbRelationUpdateCascade"
Print #1, "NewDB.Relations.Append NewRl"
Next
Next
Print #1, Chr(13)
Print #1, "'**************** Generate QueryDef ***********************"
Dim tmp As Integer
For Each Qd In Db.QueryDefs
QDefNam = Qd.Name
sql = Qd.sql
Print #1, "'------------------------
Print #1, "QDefName = "; Chr(34); QDefNam; Chr(34)
'hga`bhlq nr <Enter>
Do While InStr(sql, Chr(13)) <> 0
tmp = InStr(sql, Chr(13))
sql = Left(sql, tmp - 1) & " " & Mid(sql, tmp + 2)
Loop
'g`lemhl 2-j`b{wjs m` ndhm`pms~
Do While InStr(sql, Chr(34)) <> 0
tmp = InStr(sql, Chr(34))
sql = Left(sql, tmp - 1) & "'" & Mid(sql, tmp + 1)
Loop
CreateQD QDefNam
Print #1, "sql = "; Chr(34); sql; Chr(34)
Print #1, "Set NewQDef = NewDB.CreateQueryDef(QDefN
Next
Print #1, "'************************
Print #1, "NewDB.Close"
Print #1, "Set NewTab = Nothing"
Print #1, "Set NewIdx = Nothing"
Print #1, "Set tmpField = Nothing"
Print #1, "Set NewRl = Nothing"
Print #1, "Set NewQDef = Nothing"
Print #1, "Set NewDB = Nothing"
Print #1, "CreateNewDataBase=Err.Num
Print #1, "End Function"
Exit Sub
ErrH:
Print #1, Err.Description
Resume Next
End Sub
Sub CreateQD(mName As String)
Set NewQDef = NewDB.CreateQueryDef(mName
End Sub
Sub CreateRl(mName, nam As String, fnam As String)
Set NewRl = NewDB.CreateRelation(mName
NewRl.Table = Rel.Table
NewRl.ForeignTable = Rel.ForeignTable
Set NewField = NewRl.CreateField(nam)
NewField.ForeignName = fnam
NewRl.Fields.Append NewField
NewRl.Attributes = dbRelationUpdateCascade
NewDB.Relations.Append NewRl
End Sub
Private Sub CreateDB(mName As String)
Dim q As String
q = Dir(mName)
If Dir(mName) <> "" Then Kill (mName)
Set NewDB = WS.CreateDatabase(mName, dbLangCyrillic, dbVersion30)
End Sub
Private Sub CreateTab(mName As String)
Set NewTab = Db.CreateTableDef(mName)
End Sub
Private Sub CreateField(mName As String, mType As Long, mSize As Long, Optional mAtr As Long)
Set NewField = NewTab.CreateField(mName, mType, mSize)
NewField.Attributes = mAtr
End Sub
Private Sub CreateFieldProperty()
DescrptCount = 0
For Each fl In NewTab.Fields
If Trim(FielDescript(DescrptC
Set NewPr = fl.CreateProperty("Descrip
fl.Properties.Append NewPr
M0:
DescrptCount = DescrptCount + 1
Next
Erase FielDescript
End Sub
Private Sub CreateProperty(mVal As String)
If Trim(mVal) = "" Then Exit Sub
Set NewPr = NewTab.CreateProperty("Des
NewTab.Properties.Append NewPr
End Sub
Private Sub CreateIdx(mIdx As String)
Set NewIdx = NewTab.CreateIndex(mIdx)
NewIdx.Primary = Idx.Primary
NewIdx.Unique = Idx.Unique
End Sub
Private Sub AddFieldInIdx(mNameField As String)
Set tmpField = NewIdx.CreateField(mNameFi
End Sub
Private Function ShowType(varTypeCode As Variant) As String
Dim strRet As String
Select Case varTypeCode
Case dbInteger
strRet = "dbInteger"
Case dbLong
strRet = "dbLong"
Case dbSingle
strRet = "dbSingle"
Case dbDouble
strRet = "dbCurrency"
Case dbCurrency
strRet = "dbCurrency"
Case dbDate
strRet = "dbDate"
Case dbText
strRet = "dbText"
Case dbBoolean
strRet = "dbBoolean"
Case dbDecimal
strRet = "dbDecimal"
Case dbByte
strRet = "dbByte"
Case Else
strRet = "[ " & CStr(varTypeCode) & " ]"
End Select
ShowType = strRet
End Function
Sub MakeHead()
Print #1, "'Module:"; vbTab; "MakeDB.bas"
Print #1, "'Description:"; vbTab; "Create *.mdb file"
Print #1, "'Date:"; vbTab; vbTab; Now; Chr(13)
Print #1, "Dim NewTab As TableDef"
Print #1, "Dim NewDB As Database"
Print #1, "Dim NewField As Field"
Print #1, "Dim NewIdx As Index"
Print #1, "Dim tmpField As Field"
Print #1, "Dim NewRl As Relation"
Print #1, "Dim NewQDef As QueryDef"
Print #1, "Dim TabName as String"
Print #1, "Dim FieldName as String"
Print #1, "Dim IdxName as String"
Print #1, "Dim RelatName as String"
Print #1, "Dim QDefName as String"
Print #1, "Dim sql as String"
Print #1, "Dim DBName as String"
Print #1, "Dim TabDescript as String"
Print #1, "Dim FielDescript() as String"
Print #1, "Dim DescrCount as Integer"
Print #1, "'------------------------
End Sub
HTH
Oops, only a comment :-(((
ASKER
GordonP - thanks for the guidance... I'd like to leave the question open for a bit to see if anyone has any more ideas (particularly any add-ins or utilities as my database is quite complex). If no-one has come forward with anything by Monday I'll award you the points.
nico5038 - there is no problem with using a setup routine to deploy the database - thats what I'm doing at the moment. I'd like to get away from that method - if I create the database on the fly I can be assured that nobody has accidentally edited or removed my template. Its just neater that way.
nico5038 - there is no problem with using a setup routine to deploy the database - thats what I'm doing at the moment. I'd like to get away from that method - if I create the database on the fly I can be assured that nobody has accidentally edited or removed my template. Its just neater that way.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Samopal and Morpho... thanks - both look good and I'll look at both of them.
If they are what I need I'll post a couple of new questions so you can both have points, as well as GordonP for giving me sample code.
If they are what I need I'll post a couple of new questions so you can both have points, as well as GordonP for giving me sample code.
ASKER
Samopal... there appears to be some corruption in the code you posted... : two lines in the section creating querydefs look like garbage. Can you repost that section.
Cheers.
Cheers.
It's only comments in Russian...
Print #1, "'**************** Generate QueryDef ***********************"
Dim tmp As Integer
For Each Qd In Db.QueryDefs
QDefNam = Qd.Name
sql = Qd.sql
Print #1, "'------------------------ ---------- --------"
Print #1, "QDefName = "; Chr(34); QDefNam; Chr(34)
'delete all <Enter>
Do While InStr(sql, Chr(13)) <> 0
tmp = InStr(sql, Chr(13))
sql = Left(sql, tmp - 1) & " " & Mid(sql, tmp + 2)
Loop
'change " to '
Do While InStr(sql, Chr(34)) <> 0
tmp = InStr(sql, Chr(34))
sql = Left(sql, tmp - 1) & "'" & Mid(sql, tmp + 1)
Loop
CreateQD QDefNam
Print #1, "'**************** Generate QueryDef ***********************"
Dim tmp As Integer
For Each Qd In Db.QueryDefs
QDefNam = Qd.Name
sql = Qd.sql
Print #1, "'------------------------
Print #1, "QDefName = "; Chr(34); QDefNam; Chr(34)
'delete all <Enter>
Do While InStr(sql, Chr(13)) <> 0
tmp = InStr(sql, Chr(13))
sql = Left(sql, tmp - 1) & " " & Mid(sql, tmp + 2)
Loop
'change " to '
Do While InStr(sql, Chr(34)) <> 0
tmp = InStr(sql, Chr(34))
sql = Left(sql, tmp - 1) & "'" & Mid(sql, tmp + 1)
Loop
CreateQD QDefNam
ASKER
Ahh... thanks.
ASKER
Thanks Morpho... thats exactly what I needed.
Samopal and GordonP - I'm going to post new questions for you to to claim points for your answers.
Cheers everyone.
Samopal and GordonP - I'm going to post new questions for you to to claim points for your answers.
Cheers everyone.
ASKER