Function aTransferRelations(dbsSource As Database, dbsIn As Database) As Integer
'тут можно и вывод в log file
Dim rlt As Relation 
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
    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