Jonathan Wood said:
I've written some code to create a relationship between table A and table
B. The code looks something like this:
Set rel = db.CreateRelation("A_B")
rel.Table = "A"
rel.ForeignTable = "B"
Set fld = rel.CreateField("AID")
fld.ForeignName = "BID"
rel.Fields.Append fld
db.Relations.Append rel
This code works just fine except that a few lines later, I use DLookup()
to find a row in table B, but I then get an error that table B is
exclusively locked and cannot be accessed.
Here is the function I use for creating new relationships. I've always been
able to continue working in the db after running this code.
Public Function pjsCreateRelationship( _
dbData As DAO.Database, _
strRelationName As String, _
strParentTable As String, _
strChildTable As String, _
astrFieldNamesPrimary() As String, _
astrFieldNamesForeign() As String, _
Optional fCascadeDelete As Boolean = False, _
Optional fCascadeUpdate As Boolean = False _
) As Boolean
On Error GoTo ErrorHandler
Dim fSuccess As Boolean, relTemp As DAO.Relation, _
lngLoop As Long, lngAttributes As Long
'Make sure we were passed compatible field name arrays
If LBound(astrFieldNamesPrimary) = 0 And LBound(astrFieldNamesForeign) =
0 _
And UBound(astrFieldNamesPrimary) = UBound(astrFieldNamesForeign) Then
fSuccess = True 'Assume we succeed
'See if relationship name already exists
Set relTemp = dbData.Relations(strRelationName)
Else 'Bad calling parameters
Err.Raise Number:=9999, Description:="Programmer Error: Invalid
calling parameters"
End If
If relTemp Is Nothing Then 'Return here from error handler
With dbData
lngAttributes = IIf(fCascadeDelete, dbRelationDeleteCascade, 0)
+ _
IIf(fCascadeUpdate, dbRelationUpdateCascade, 0)
Set relTemp = .CreateRelation(strRelationName, strParentTable,
strChildTable, lngAttributes)
With relTemp
For lngLoop = 0 To UBound(astrFieldNamesPrimary)
.Fields.Append
..CreateField(astrFieldNamesPrimary(lngLoop))
.Fields(lngLoop).ForeignName =
astrFieldNamesForeign(lngLoop)
Next lngLoop
End With
.Relations.Append relTemp
.Relations.Refresh
End With
CurrentDb.Relations.Refresh
Else 'Could verify the existing relationship has the same attributes
and fields
End If
ExitHandler:
On Error Resume Next
pjsCreateRelationship = fSuccess
Set relTemp = Nothing
Exit Function
ErrorHandler:
Select Case Err.Number
Case 3265 'Name doesn't exist in this collection
Resume Next
Case Else
'Your error handling code
fSuccess = False
End Select
Resume ExitHandler
Resume
End Function
