Function aDeleteRelations(dbsSource As Database) As Integer
Dim rlt As Relation
Dim i As Long

Dim rName As String
'On Error Resume Next
    For i = dbsSource.Relations.Count -  1  To  0  Step - 1 
        rName = dbsSource.Relations(i).Name
        dbsSource.Relations.Delete rName
        dbsSource.Relations.Refresh
    Next i

End Function

Function aTransferRelations(dbsSource As Database, dbsIn As Database) As Integer
'тут нужно предусмотреть перехват совпадения имен (связей)
'результат - от количества обновленных - все/не все/ни одной?
'log file
Dim rlt As Relation ', dbsIn As Database
Dim rltIn As Relation

Dim i As Long, k As Long
Dim aName As String, aForeignTable As String, aTable  As String
Dim anAttrib, aField As String, aForeignName As String
Dim aFstr As String
On Error Resume Next
    'Set dbsIn = CurrentDB()
    For k = 0 To dbsSource.Relations.Count - 1
        Set rlt = dbsSource.Relations(k)
        aName = rlt.Name
        aForeignTable = rlt.ForeignTable
        aTable = rlt.Table
        anAttrib = rlt.Attributes
        aFstr = ""
        Set rltIn = dbsIn.CreateRelation(aName, aTable, aForeignTable, anAttrib)
        For i = 0 To rlt.Fields.Count - 1
            'тут добавить поля связи
            aField = rlt.Fields(i).Name
            aForeignName = rlt.Fields(i).ForeignName
            aFstr = aFstr & aField &  "-"  & aForeignName &  ";" 
            rltIn.Fields.Append rltIn.CreateField(aField)
            rltIn.Fields(aField).ForeignName = aForeignName
        Next i
        dbsIn.Relations.Append rltIn
        If Err <>  0  Then
            Debug.Print rltIn.Name; ; Err.Description
            Debug.Print aTable &  "-" ; aForeignTable &  " "  & aFstr
            Err.Clear
        End If
         'просто передать все по указателю нельзя {* dbsIn.Relations.Append rlt *} - неверно
    Next k

    Set rlt = Nothing
    Set rltIn = Nothing
    'Set dbsIn = Nothing
    
    aTransferRelations = True
End Function

Function tr_rel(FilePathSource As String, FilePathIn As String) As Integer
Dim dbsSource As Database, dbsIn As Database, result As Integer
    Set dbsSource = OpenDatabase(FilePathSource)
    Set dbsIn = OpenDatabase(FilePathIn)
    result = aDeleteRelations(dbsIn)
'...
    result = aTransferRelations(dbsSource, dbsIn)
    Set dbsSource = Nothing
    tr_rel = True
End Function