ACC2000: How to Use DAO in Visual Basic Code to Import Relationships

Function ImportRelations(DbName As String) As Integer
'------------------------------------------------------------------
' PURPOSE: Imports relationships where table names and field names
'          match.
' ACCEPTS: The name of the external database as a string.
' RETURNS: The number of relationships imported as an integer.
'------------------------------------------------------------------

Dim ThisDb As DAO.Database, ThatDB As DAO.Database
Dim ThisRel As DAO.Relation, ThatRel As DAO.Relation
Dim ThisField As DAO.Field, ThatField As DAO.Field
Dim Cr As String, i As Integer, cnt As Integer, RCount As Integer
Dim j As Integer
Dim ErrBadField As Integer

Cr$ = Chr$(13)
RCount = 0

Set ThisDb = CurrentDb()
Set ThatDB = DBEngine.Workspaces(0).OpenDatabase(DbName$)

' Loop through all existing relationships in the external database.
For i = 0 To ThatDB.Relations.Count - 1
   Set ThatRel = ThatDB.Relations(i)

   ' Create 'ThisRel' using values from 'ThatRel'.
   Set ThisRel = ThisDb.CreateRelation(ThatRel.Name, _
      ThatRel.table, ThatRel.foreigntable, ThatRel.Attributes)

   ' Set bad field flag to false.
   ErrBadField = False

   ' Loop through all fields in that relation.
   For j = 0 To ThatRel.Fields.Count - 1
      Set ThatField = ThatRel.Fields(j)

      ' Create 'ThisField' using values from 'ThatField'.
      Set ThisField = ThisRel.CreateField(ThatField.Name)
      ThisField.foreignname = ThatField.foreignname

      ' Check for bad fields.
      On Error Resume Next
      ThisRel.Fields.Append ThisField
      If Err <> False Then ErrBadField = True
      On Error GoTo 0
   Next j

   ' If any field of this relationship caused an error,
   ' do not add this relationship.
   If ErrBadField = True Then
      ' Something went wrong with the fields.
      ' Do not do anything.
   Else
      ' Try to append the relation.
      On Error Resume Next
      ThisDb.Relations.Append ThisRel
      If Err <> False Then
         ' Something went wrong with the relationship.
         ' Skip it.
      Else
         ' Keep count of successful imports.
         RCount = RCount + 1
      End If
      On Error GoTo 0
   End If
Next i

' Close databases.
ThisDb.Close
ThatDB.Close

' Return number of successful imports.
ImportRelations = RCount

End Function