There were errors with undeclared variables in your code. I strongly suggest that all code modules begin with these two lines:
Code:
Option Compare Database
Option Explicit
This is your code modified. I have included commented changes, but all might not be commented. I assume the code is contained in a database that is not the database being modified.
Code:
Option Compare Database
Option Explicit
Function ReplaceRelationship(ByVal vFilePath As Variant, _
strRelationName As String, _
strTblName As String, _
strForeignTblName As String, _
strFldPK As String, _
strForeignFld As String, _
Optional ByVal intAttrib As Integer = -1) As Boolean
Dim rel As DAO.Relation
Dim newrelation As DAO.Relation
Dim fld As DAO.Field
Dim relatingField As DAO.Field
Dim relationUniqueName As String
Dim gsdbs As DAO.Database 'this is necessary!
'On Error Resume Next
Set gsdbs = OpenDatabase(vFilePath)
'delete the existing relationship
'gsdbs.Relations.Delete strRelationName 'How do you know the name? Not needed anyway.
'there may be redundant / parallel relationships (?) that could be in conflict with the new definition;
'they need to also be deleted
For Each rel In gsdbs.Relations
If rel.Table = strTblName And rel.ForeignTable = strForeignTblName Then 'check for left or right join relationships
For Each fld In rel.Fields
If fld.Name = strFldPK Then
gsdbs.Relations.Delete rel.Name
Exit For 'no use to iterate more, can only be one match, avoids an error
End If
Next
End If
Next
'Stop
'Create a new relation.
'Specify relationship name:
relationUniqueName = strTblName + "_" + strFldPK + _
"__" + strForeignTblName + "_" + strForeignFld
'Specify attributes for cascading updates and deletes.
If intAttrib = -1 Then
intAttrib = dbRelationUpdateCascade + dbRelationDeleteCascade
End If
Set newrelation = gsdbs.CreateRelation(relationUniqueName, _
strTblName, strForeignTblName, intAttrib) 'fixed variable name
'The field from the primary table.
Set relatingField = newrelation.CreateField(strFldPK)
'Matching field from the related table.
relatingField.ForeignName = strForeignFld
'Add the field to the relation's Fields collection.
newrelation.Fields.Append relatingField
'Add the relation to the database.
gsdbs.Relations.Append newrelation
gsdbs.Close
If Err = 0 Then GoTo ExitRoutine
ErrHandler:
Debug.Print "Error handler enabled"
MsgBox "Error handler enabled" _
& vbCrLf _
& vbCrLf & "module: ReplaceRelationships" _
& vbCrLf & "an error occured in line: " & Erl & vbCrLf & "error no. " & Err.Number & ": " & Err.Description _
& vbCrLf & "Primary Table: " & strTblName _
& vbCrLf & "Foreign Table: " & strForeignTblName _
& vbCrLf & "common field (pri:foreign) : " & strFldPK & " : " & strForeignFld
ExitRoutine:
ReplaceRelationship = True
'Clean up
Set fld = Nothing
Set rel = Nothing
Set gsdbs = Nothing
' Exit Function
End Function