Mile-O
Back once again...
- Local time
- Today, 10:48
- Joined
- Dec 10, 2002
- Messages
- 11,316
I'm trying to create a table via ADOX using a few class modules. I want to make it a little more dynamic so that I can simply put fields into a class collection and then pass the collection to another class so that whatever fields I pass in are used to create a table.
At the moment there's no validation (i.e. number of fields) and the only function I've almost got is to create the table.
I now that the problem is due to trying to loop through one instance of a class but I seem unable to do so. I've highlighted the problem in red.
The code of each module is as follows:
MODULE: basTest
CLASS: CField
CLASS: CFields
CLASS: CFields
At the moment there's no validation (i.e. number of fields) and the only function I've almost got is to create the table.
I now that the problem is due to trying to loop through one instance of a class but I seem unable to do so. I've highlighted the problem in red.
The code of each module is as follows:
MODULE: basTest
Code:
Public Function Test() As Boolean
On Error GoTo Err_Test
Const TableName As String = "tblPortfolio"
Const cSuccess As String = "Table created"
Const cFailure As String = "Table not created"
Const TestField1 As String = "PortfolioID"
Const TestField2 As String = "Portfolio"
Const TestField3 As String = "DateExpired"
Dim clsFields As CFields
Dim clsTable As CTable
Set clsFields = New CFields
Set clsTable = New CTable
With clsFields
.Add TestField1, adInteger, True
.Add TestField2
.Add TestField3, adDate
End With
If clsTable.CreateTable(TableName, clsFields) Then
MsgBox cSuccess, vbInformation
Else
MsgBox cFailure, vbExclamation
End If
Test = True
Exit_Test:
Set clsTable = Nothing
Set clsFields = Nothing
Exit Function
Err_Test:
Test = False
Resume Exit_Test
End FunctionCLASS: CField
Code:
Option Compare Database
Option Explicit
Public FieldName As String
Public FieldType As Long
Public IsKey As Boolean
Private mstrID As String
Property Get ID() As String
ID = mstrID
End Property
Property Let ID(ByVal strNew As String)
Static booSet As Boolean
If Not booSet Then
booSet = True
mstrID = strNew
End If
End PropertyCLASS: CFields
Code:
Option Compare Database
Option Explicit
Private mcolFields As New Collection
Private mKeyCount As Long
Public Function Add(ByVal FName As String, Optional ByVal FType As Long = adVarWChar, _
Optional FKey As Boolean = False) As CField
Dim clsNew As New CField
Static lngFieldNum As Long
With clsNew
lngFieldNum = lngFieldNum + 1
.ID = lngFieldNum
.FieldName = FName
.FieldType = FType
.IsKey = FKey
If FKey Then
mKeyCount = mKeyCount + 1
End If
mcolFields.Add clsNew, .ID
End With
Set Add = clsNew
End Function
Public Function Count() As Long
Count = mcolFields.Count
End Function
Public Function KeyCount() As Long
KeyCount = mKeyCount
End Function
Public Sub Delete(ByVal Index As Variant)
Dim x As New CField
Set x = mcolFields.Item(Index)
If x.IsKey Then
mKeyCount = mKeyCount - 1
End If
mcolFields.Remove Index
Set x = Nothing
End Sub
Public Function Item(ByVal Index As Variant) As CField
Set Item = mcolFields.Item(Index)
End FunctionCLASS: CFields
Code:
Option Compare Database
Option Explicit
Private cn As ADODB.Connection
Private cat As ADOX.Catalog
Private Sub Class_Initialize()
Set cn = New ADODB.Connection
Set cn = CurrentProject.Connection
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = cn
End Sub
Private Sub Class_Terminate()
cn.Close
Set cat = Nothing
Set cn = Nothing
End Sub
Public Function CreateTable(ByVal TableName As String, xFields As CFields) As Boolean
On Error GoTo Err_CreateTable
Const cPrimKey As String = "PrimaryKey"
Dim vField As CField
Set vField = New CField
Dim objTable As ADOX.Table
Set objTable = New ADOX.Table
objTable.Name = TableName
[color=red][b]For Each vField In xFields[/b][/color]
With objTable
.Columns.Append vField.FieldName, vField.FieldType
If vField.IsKey Then
.Keys.Append cPrimKey, adKeyPrimary, vField.FieldName
End If
End With
Next
cat.Tables.Append objTable
CreateTable = True
Exit_CreateTable:
Set vField = Nothing
Set objTable = Nothing
Exit Function
Err_CreateTable:
CreateTable = False
Resume Exit_CreateTable
End Function
