Hello,
My question is about how to create a foreign key from a VBA Module.
Is it possible to create foreign keys from a VBA module just as you do primary keys?
I've been able to create two tables with primary keys from a module in access and then load them with data from an excel spreadsheet. But I would also like to create foreign keys from my access module as well.
The three functions I have coded below are how I've been creating primary keys for my two tables. Can someone tell me what to add to create foreign keys?
Thanks in advance! I appreciate any and all suggestions!!
Code:
Public Sub CreatePKIndexes(strTableName As String, ParamArray varPKFields())
' declarations
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim idx As DAO.Index
Dim fld As DAO.Field
' declare string for key
Dim strPKey As String
' declare string for index field's name
Dim strIdxFldName As String
' declare int for counting
Dim intCounter As Integer
' Create current Database
Set dbs = CurrentDb
' Create table definition in memory
Set tdf = dbs.TableDefs(strTableName)
' Check if a Primary Key exists.
' If so, delete it.
strPKey = GetPrimaryKey(tdf)
If Len(strPKey) > 0 Then
tdf.Indexes.Delete strPKey
End If
' Create a new primary key
Set idx = tdf.CreateIndex("PrimaryKey")
idx.Primary = True
idx.Required = True
idx.Unique = True
' Append the fields
For intCounter = LBound(varPKFields) To UBound(varPKFields)
' get the field name
strIdxFldName = varPKFields(intCounter)
' get the field object and append it to the index
Set fld = idx.CreateField(strIdxFldName)
idx.Fields.Append fld
Next intCounter
' Append the index to the Indexes collection
tdf.Indexes.Append idx
' Refresh the Indexes collection
tdf.Indexes.Refresh
Set fld = Nothing
Set idx = Nothing
Set tdf = Nothing
Set dbs = Nothing
End Sub
Public Function GetPrimaryKey(tdf As DAO.TableDef) As String
' Determine if the specified Primary Key exists
Dim idx As DAO.Index
For Each idx In tdf.Indexes
If idx.Primary Then
' If a Primary Key exists, return its name
GetPrimaryKey = idx.Name
Exit Function
End If
Next idx
' If no Primary Key exists, return empty string
GetPrimaryKey = vbNullString
End Function
Public Sub CreateRelation(strRelName As String, _
strSrcTable As String, _
strSrcField As String, _
strDestTable As String, _
strDestField As String)
Dim dbs As DAO.Database
Dim fld As DAO.Field
Dim rel As DAO.Relation
Dim varRel As Variant
Set dbs = CurrentDb
On Error Resume Next
' Check if the relationship already exists.
' If so, delete it.
If IsObject(dbs.Relations(strRelName)) Then
dbs.Relations.Delete strRelName
End If
On Error GoTo 0
' Create the relation object
Set rel = dbs.CreateRelation(strRelName, strSrcTable, strDestTable)
' Referential integrity = Cascade Update and Cascade Delete
rel.Attributes = dbRelationLeft Or _
dbRelationUpdateCascade Or _
dbRelationDeleteCascade
Set fld = rel.CreateField(strSrcField)
fld.ForeignName = strDestField
' Append the field to the relation's Fields collection
rel.Fields.Append fld
' Append the relaton to the Database's Relations collection
dbs.Relations.Refresh
Set rel = Nothing
Set fld = Nothing
Set dbs = Nothing
End Sub
Public Sub CreateSchemaForTables()
' Call all my subs
' Create the first table
CreateTableOne
CreatePKIndexes "tblOne", "ID1"
' Create the second table
CreateTableTwo
CreatePKIndexes "tblTwo", "ID2"
' Finally, create the relations for those tables
CreateRelation "Relation1", "tblOne", "ID1", "tblTwo", "ID2"
End Sub