Dynamic Relationship Building

Question

I have to copy a database, but it's proving to be more difficult than I thought. The problem is, there has to be minor modifications (such as alterations to the primary keys) so I can't just use traditional database copying techniques. I have copied the tables using TransferDatabase. This copies the indexes, but not the relations. How can I copy relationships?

Answer

Richard,

This function should do the trick:

Public Function TblsAndRelsClone(ByVal vstrClonedDBfullPath As String)
    Dim dbsSrc As Database
    Dim tdfSrc As TableDef
    Dim relSrc As Relation
    Dim fldSrc As Field
    
    Dim dbsDst As Database
    Dim tdfDst As TableDef
    Dim relDst As Relation
    Dim fldDst As Field
    
    Set dbsSrc = CurrentDb()
    On Error Resume Next
    Kill vstrClonedDBfullPath
    On Error GoTo 0
    
    Set dbsDst = DBEngine(0).CreateDatabase(vstrClonedDBfullPath, dbLangGeneral)
    
    For Each tdfSrc In dbsSrc.TableDefs
      If Left(tdfSrc.Name, 4) <> "Msys" And Left(tdfSrc.Name, 4) <> "USys" Then
         DoCmd.TransferDatabase acExport, "Microsoft Access", dbsDst.Name, _
                             acTable, tdfSrc.Name, tdfSrc.Name
      End If
    Next
    
    For Each relSrc In dbsSrc.Relations
        Set relDst = dbsDst.CreateRelation(relSrc.Name, relSrc.Table, _
                                          relSrc.ForeignTable, relSrc.Attributes)
        For Each fldSrc In relSrc.Fields
           Set fldDst = relDst.CreateField(fldSrc.Name)
           fldDst.ForeignName = fldSrc.ForeignName
           relDst.Fields.Append fldDst
        Next
        
        dbsDst.Relations.Append relDst
    Next
    
    Set fldDst = Nothing
    Set relDst = Nothing
    Set tdfDst = Nothing
    Set dbsDst = Nothing
    
    Set fldSrc = Nothing
    Set relSrc = Nothing
    Set tdfSrc = Nothing
    Set dbsSrc = Nothing
End Function

HTH,
Shamil