Dynamic Relationship Building


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?



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
    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
        dbsDst.Relations.Append relDst
    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


Copyright 1999-2008 by Shamil Salakhetdinov.  All rights reserved.