Creating Tables and Fields using VBA into a Secured Access 2007 Database having Workspace issues

Option Compare Database
Option Explicit
Function CreateDBFile()
 
'Dev Tool consists of 4 Tables, BackEnd Database Names,Tables(that belong in each BE Database), Fields(that belong in each table), Relationships (between tables).
'BackendDatabases(BE_DB_Name,Encrypted,Password,DateCreated)
'Tables(BEDatabase,Table-Name,DateCreated)
'Fields(Table,FieldName,Datatype,Fieldsize,DefaultValue,Required,AllowZeroLength)
'Relationships(BEDatabase,PrimaryTable,PrimaryField,LinkedTable,LinkedField)
Dim i As Integer
Dim DbFileName As String
Dim DTTL_TableName As String
 
'Dev Tool Items
Dim Path As String
Dim DevToolWorkspace As Workspace
Dim DevToolDatabase As DAO.Database
'BackendDatabases Table (Dev Tool Items)
Dim DevToolBEDBList As DAO.Recordset
'Tables Table  (Dev Tool Items)
Dim DevToolTablesList As DAO.Recordset
'Fields Table  (Dev Tool Items)
Dim DevToolFieldsList As DAO.Recordset
'Relationships Table  (Dev Tool Items)
Dim DevToolRelationshipsList As DAO.Recordset
 
'Dynamically Created Database Items
Dim BEDatabase As DAO.Database
Dim BEWorkspace As Workspace
Dim BETable As DAO.TableDef
Dim BEField As DAO.Field
 
'Standard Fields to create
Dim BEIDField As DAO.Field
Dim BEIndex As DAO.Index
Dim BEFieldIndex As DAO.Field
Dim BETransIDField As DAO.Field
Dim BEEnteredDate As DAO.Field
Dim BEEnteredBy As DAO.Field
Dim BEModifiedDate As DAO.Field
Dim BEModifiedBy As DAO.Field
 
'Relationships to be Created
Dim BERelationship As DAO.Relation
 
        
    'Find the Path this DevTool is installed in also will be the install path for BE Databases
    Set DevToolWorkspace = CreateWorkspace("", "admin", "")
    Set DevToolDatabase = CurrentDb()
        For i = Len(DevToolDatabase.Name) To 1 Step -1
            If Mid(DevToolDatabase.Name, i, 1) = Chr(92) Then
                Path = Mid(DevToolDatabase.Name, 1, i)
        Exit For
        End If
        Next
    
         
    'Open BackendDatabases Table
    Set DevToolBEDBList = DevToolDatabase.OpenRecordset("BackendDatabases")
          
    'Create all Backend Database Files that do not already exist, Loop through BackendDatabases Table to find names of files and check for encryption/password
    Do Until DevToolBEDBList.EOF
            DbFileName = Path & DevToolBEDBList("BE_DB_Name") & ".accdb"
        'if the file doesnt exist, then use DevTool Workspace to create the BEdatabase and encrypt if necessary with single password
        If Dir(DbFileName) = "" Then
            If DevToolBEDBList("Encrypted") = False Then
                Set BEDatabase = DevToolWorkspace.CreateDatabase(DbFileName, dbLangGeneral, dbVersion120)
            Else
                Set BEDatabase = DevToolWorkspace.CreateDatabase(DbFileName, dbLangGeneral & ";pwd=" & DevToolBEDBList("Password"), dbEncrypt)
            End If
            BEDatabase.Close
        End If
        
    'If the file already existed or just was created, Reopen The database and Create Tables from the DevToolTablesList, Fields and Finally the relationships
    'Check if the database is Encryted, if it is not create a standard workspace, if it is create a workspace with the password in the BackendTables Table
    If DevToolBEDBList("Encrypted") = False Then
        Set BEWorkspace = CreateWorkspace("", "admin", "")
        Set BEDatabase = BEWorkspace.OpenDatabase(DbFileName, True, False)
    Else
        Set BEWorkspace = CreateWorkspace("", "admin", DevToolBEDBList("Password"))
        Set BEDatabase = BEWorkspace.OpenDatabase(DbFileName, True, False)
    End If
    
    'Open the Tables Table in the Dev Tool and Create Tables that belong in the currently opened BEDatabase
    Set DevToolTablesList = DevToolDatabase.OpenRecordset("SELECT * FROM Tables WHERE [BEDatabase]" & " = '" & DevToolBEDBList("BE_DB_Name") & "';")
    'Loop Through Tables and create them in the right BEDatabases
    Do Until DevToolTablesList.EOF
        Set BETable = BEDatabase.CreateTableDef(DevToolTablesList("Table-Name"))
        DTTL_TableName = DevToolTablesList("Table-Name")
        'If the Table Already Exists then open it, Otherwise create it.
            'If BEDatabase.TableDefs <> DTTL_TableName Then
                On Error Resume Next
                'If you need to create the table create it with the standard Fields
            
                'Create the Primary Field, Autoincr
                Set BEIDField = BETable.CreateField("ID_" & DTTL_TableName, dbLong)
                BEIDField.Attributes = BEIDField.Attributes + dbAutoIncrField
                BETable.Fields.Append BEIDField
                Set BEIndex = BETable.CreateIndex("PrimaryKey")
                Set BEFieldIndex = BEIndex.CreateField("ID_" & DTTL_TableName, dbLong)
                BEIndex.Fields.Append BEFieldIndex
                BEIndex.Primary = True
                BETable.Indexes.Append BEIndex
                
                'Create a Backup ID field for DataTransfers, Future and Past
                Set BETransIDField = BETable.CreateField("ID_Transfer_" & DTTL_TableName, dbLong)
                BETable.Fields.Append BETransIDField
            
                'Create Standard, Created/Modified Date/By
                Set BEEnteredDate = BETable.CreateField("Entered_Date", dbDate)
                BEEnteredDate.DefaultValue = "Now()"
                BETable.Fields.Append BEEnteredDate
                Set BEEnteredBy = BETable.CreateField("Entered_By", dbText)
                BETable.Fields.Append BEEnteredBy
                Set BEModifiedDate = BETable.CreateField("Modified_Date", dbDate)
                BEModifiedDate.DefaultValue = "Now()"
                BETable.Fields.Append BEModifiedDate
                Set BEModifiedBy = BETable.CreateField("Modified_By", dbText)
                BETable.Fields.Append BEModifiedBy
                
            'End If
        
        'Append the Table with the standard fields, refresh the list
        BEDatabase.TableDefs.Append BETable
        BEDatabase.TableDefs.Refresh
        
        'Find the Fields in the Fields Table and Create them in the Current Table and Currently Opened BE Database
        Set DevToolFieldsList = DevToolDatabase.OpenRecordset("SELECT * FROM Fields WHERE [Table]" & " = '" & DTTL_TableName & "';")
        Set BETable = BEDatabase.TableDefs(DTTL_TableName)
            
            'Loop through field list, create fields according to type.
            Do Until DevToolFieldsList.EOF
            
                'Use CASE due to string limitations in CreateField Method
                Select Case DevToolFieldsList("DataType")
                    Case "DbText"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbText)
                    Case "dbBigInt"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbBigInt)
                    Case "dbBinary"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbBinary)
                    Case "dbBoolean"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbBoolean)
                    Case "dbByte"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbByte)
                    Case "dbChar"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbChar)
                    Case "dbCurrency"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbCurrency)
                    Case "dbDate"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbDate)
                    Case "dbDecimal"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbDecimal)
                    Case "dbDouble"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbDouble)
                    Case "dbFloat"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbFloat)
                    Case "dbGUID"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbGUID)
                    Case "dbInteger"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbInteger)
                    Case "dbLong"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbLong)
                    Case "dbLongBinary"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbLongBinary)
                    Case "dbMemo"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbMemo)
                    Case "dbNumeric"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbNumeric)
                    Case "dbSingle"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbSingle)
                    Case "dbTime"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbTime)
                    Case "dbTimeStamp"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbTimeStamp)
                    Case "dbVarBinary"
                        Set BEField = BETable.CreateField(DevToolFieldsList("FieldName"), dbVarBinary)
                End Select
                    
                'Set Other Attributes of the field, not avaiable in the createField Method
                If DevToolFieldsList("FieldSize") Is Not Null Then
                    BEField.Size = DevToolFieldsList("FieldSize")
                End If
                If DevToolFieldsList("DefaultValue") Is Not Null Then
                    BEField.DefaultValue = DevToolFieldsList("DefaultValue")
                End If
                If DevToolFieldsList("Required") Is Not Null Then
                    BEField.Required = DevToolFieldsList("Required")
                End If
                If DevToolFieldsList("AllowZeroLength") Is Not Null Then
                    BEField.AllowZeroLength = DevToolFieldsList("AllowZeroLength")
                End If
                    
                'Append the New Field to the Current BETable
                On Error Resume Next
                BETable.Fields.Append BEField
            'Go to Next Field to be created and Loop
            DevToolFieldsList.MoveNext
            Loop
                    
    'Loop to the Next Table in the Table List
    DevToolTablesList.MoveNext
    Loop
        
    'Open the Relationships Table from this DevTool and Find relationships to be created
    Set DevToolRelationshipsList = DevToolDatabase.OpenRecordset("SELECT * FROM Relationships WHERE [BEDatabase]" & " = '" & DevToolBEDBList("BE_DB_Name") & "';")
    
    'If there are relationships to be created, Create them
    If DevToolRelationshipsList.RecordCount > 0 Then
        'Loop through Relatoinships Table and Create Relationships in the Target BE Database
        Do Until DevToolRelationshipsList.EOF
              'Create the relationship naming it with linked table name and linked field name, set the primary table and linked table
              Set BERelationship = BEDatabase.CreateRelation(DevToolRelationshipsList("LinkedTable") & " " & DevToolRelationshipsList("LinkedField"), DevToolRelationshipsList("PrimaryTable"), DevToolRelationshipsList("LinkedTable"), dbRelationDeleteCascade)
              
              'Create the Field tracking the primary field, and set the foreignname property of that field, append the field change
              Set BEField = BERelationship.CreateField(DevToolRelationshipsList("PrimaryField"))
              BEField.ForeignName = DevToolRelationshipsList("LinkedField")
              BERelationship.Fields.Append BEField
              
              'Append the relationship, refresh
              BEDatabase.Relations.Append BERelationship
              BEDatabase.Relations.Refresh
              
        'Move to next relationship in the DevTool Relationship Table and loop
        DevToolRelationshipsList.MoveNext
        Loop
    End If
 
    'Close the Current BE Database and Workspace
    BEDatabase.Close
    BEWorkspace.Close
    
    'Go to Next BE Database and Loop
    DevToolBEDBList.MoveNext
    On Error Resume Next
    Loop
                       
End Function

Select allOpen in new window