Trying to copy table relationships to new database file

I have the following code working well to create a new Access database file and copy certain records over to it.  But I am not getting the relationships copied over via lines:

    'Copy relationship between the two tables
    Set rel = .CreateRelation(Name:="[rel.Name]", Table:="[rel.tblDataHeader]", ForeignTable:="[rel.tblDataDetail]", Attributes:=[rel.Attributes])
        rel.Fields.Append rel.CreateField("[fld.Name for relation]")
        rel.Fields("[fld.RECORD_NUMBER for relation]").ForeignName = "[fld.RECORD_NUMBER for relation]"
        .Relations.Append rel

Open in new window




Code:

Private Sub cmdArchiveTables_Click()

    If IsNull(Me.txtDate) Then
        MsgBox "You must enter a date."
        Me.txtDate.SetFocus
        Exit Sub
    End If

    If MsgBox("This function will archive data records per the date range you have specified.  Please be sure to create a backup file copy of your current working database before proceeding.  Do you wish to continue??", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then

    Dim ws As Workspace
    Dim db As Database
    Dim LFilename As String
    Dim tblDataHeader As Object
    Dim tblDataDetail As Object

   'Get default Workspace
    Set ws = DBEngine.Workspaces(0)

   'Path and file name for new mdb file
    LFilename = Me.txtFileNameAndLocation & ".accdb"
    
    MsgBox Me.txtFileNameAndLocation & ".accdb"

   'Make sure there isn't already a file with the name of the new database
    If Dir(LFilename) <> "" Then Kill LFilename

   'Create a new accdb file
    Set db = ws.CreateDatabase(LFilename, dbLangGeneral)

   'Export tables to new database
    DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "qryHeaderRecordsToArchive", "tblDataHeader", False
    DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "qryDetailRecordsToArchive", "tblDataDetail", False
    
    'Copy relationship between the two tables
    Set rel = .CreateRelation(Name:="[rel.Name]", Table:="[rel.tblDataHeader]", ForeignTable:="[rel.tblDataDetail]", Attributes:=[rel.Attributes])
        rel.Fields.Append rel.CreateField("[fld.Name for relation]")
        rel.Fields("[fld.RECORD_NUMBER for relation]").ForeignName = "[fld.RECORD_NUMBER for relation]"
        .Relations.Append rel

    db.Close
    DoCmd.Close acForm, "frmDateRangeForDataArchive"
   
    Set db = CurrentDb
   
    DoCmd.SetWarnings False
        DoCmd.OpenQuery "delqryRecordsToArchive"
    DoCmd.SetWarnings True
        Else
        Exit Sub
    End If

End Sub

Open in new window

SteveL13Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rey Obrero (Capricorn1)Commented:
try


  Set rel = db.CreateRelation(Name:="[rel.Name]", Table:="[rel.tblDataHeader]", ForeignTable:="[rel.tblDataDetail]", Attributes:=[rel.Attributes])
        rel.Fields.Append rel.CreateField("[fld.Name for relation]")
        rel.Fields("[fld.RECORD_NUMBER for relation]").ForeignName = "[fld.RECORD_NUMBER for relation]"
        db.Relations.Append rel
SteveL13Author Commented:
Am getting an error when I try to compile.  Variable not defined.

At

rel =
Rey Obrero (Capricorn1)Commented:
you need to declare rel
dim rel as dao.relation

also see this link CreateRelation as reference
OWASP Proactive Controls

Learn the most important control and control categories that every architect and developer should include in their projects.

SteveL13Author Commented:
I declared it with dim rel as dao.relation.

But the code didn't run - Runtime error 2465.  ... can't find the field '|1' referred to in your expression.

Code stopped at this line:

Set rel = db.CreateRelation(Name:="[rel.Name]", Table:="[rel.tblDataHeader]", ForeignTable:="[rel.tblDataDetail]", Attributes:=[rel.Attributes])
Rey Obrero (Capricorn1)Commented:
check the link the I posted above
SteveL13Author Commented:
I will.  It looks like totally different code.
SteveL13Author Commented:
I tried.  I pasted the code in the bottom of the code for the form that has the command button to onclick run this.  Isn't working.  I'm sure I have something messed up.

Private Function CreateRelation(tblDataHeader As String, _
                                RECORD_NUMBER As String, _
                                tblDataDetail As String, _
                                RECORD_NUMBER As String) As Boolean
On Error GoTo ErrHandler

    Dim db As DAO.Database
    Dim newRelation As DAO.Relation
    Dim relatingField As DAO.Field
    Dim RECORD_NUMBER As String
   
    relationUniqueName = tblDataHeader + "_" + RECORD_NUMBER + _
                         "__" + tblDataDetail + "_" + RECORD_NUMBER
   
'    Set db = CurrentDb()
   
    'Arguments for CreateRelation(): any unique name,
    'primary table, related table, attributes.
    Set newRelation = db.CreateRelation(relationUniqueName, _
                            tblDataHeader, tblDataDetail)
    'The field from the primary table.
    Set relatingField = newRelation.CreateField(RECORD_NUMBER)
    'Matching field from the related table.
    relatingField.ForeignName = RECORD_NUMBER
    'Add the field to the relation's Fields collection.
    newRelation.Fields.Append RECORD_NUMBER
    'Add the relation to the database.
    db.Relations.Append newRelation
   
'    Set db = Nothing
   
    CreateRelation = True
       
Exit Function

ErrHandler:
    Debug.Print Err.Description + " (" + relationUniqueName + ")"
    CreateRelation = False
End Function

Public Function CreateAllRelations()

    Dim db As DAO.Database
    Dim totalRelations As Integer
   
    Set db = CurrentDb()
    totalRelations = db.Relations.Count
    If totalRelations > 0 Then
        For i = totalRelations - 1 To 0 Step -1
            db.Relations.Delete (db.Relations(i).Name)
        Next i
        Debug.Print Trim(Str(totalRelations)) + " Relationships deleted!"
    End If
   
    Debug.Print "Creating Relations..."
   
    ''==========================
    ''Example
    'Employee Master to Employee CheckIn
    Debug.Print CreateRelation("tblDataHeader", "RECORD_NUMBER", _
                               "tblDataDetail", "RECORD_NUMBER")
   
    ''Orders to Order Details
'    Debug.Print CreateRelation("Orders", "No", _
                               "OrderDetails", "No")
    ''==========================
   
    totalRelations = db.Relations.Count
    Set db = Nothing
   
    Debug.Print Trim(Str(totalRelations)) + " Relationships created!"
    Debug.Print "Completed!"
End Function
SteveL13Author Commented:
When I try to compile I get duplicate declaration in project scope at :

Private Function CreateRelation(tblDataHeader As String, _
                                RECORD_NUMBER As String, _
                                tblDataDetail As String, _
                                RECORD_NUMBER As String) As Boolean
Rey Obrero (Capricorn1)Commented:
why did you comment this lines

'    Set db = CurrentDb()

'    Set db = Nothing


<When I try to compile I get duplicate declaration in project scope at :>
this   RECORD_NUMBER As String was repated
Private Function CreateRelation(tblDataHeader As String, _
                                 RECORD_NUMBER As String, _    '<<<<
                                 tblDataDetail As String, _
                                 RECORD_NUMBER As String) As Boolean  '<<<<<<
SteveL13Author Commented:
I actually tried to UNcomment it.  Still didn't work.

Here is all the code in the form.

Private Sub cmdArchiveTables_Click()

    If IsNull(Me.txtDate) Then
        MsgBox "You must enter a date."
        Me.txtDate.SetFocus
        Exit Sub
    End If

    If MsgBox("This function will archive data records per the date range you have specified.  Please be sure to create a backup file copy of your current working database before proceeding.  Do you wish to continue??", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then

    Dim ws As Workspace
    Dim db As Database
    Dim LFilename As String
    Dim tblDataHeader As Object
    Dim tblDataDetail As Object
    Dim rel As DAO.Relation

   'Get default Workspace
    Set ws = DBEngine.Workspaces(0)

   'Path and file name for new mdb file
    LFilename = Me.txtFileNameAndLocation & ".accdb"
   
    MsgBox Me.txtFileNameAndLocation & ".accdb"

   'Make sure there isn't already a file with the name of the new database
    If Dir(LFilename) <> "" Then Kill LFilename

   'Create a new accdb file
    Set db = ws.CreateDatabase(LFilename, dbLangGeneral)

   'Export tables to new database
    DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "qryHeaderRecordsToArchive", "tblDataHeader", False
    DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "qryDetailRecordsToArchive", "tblDataDetail", False
   
    'Copy relationship between the two tables
    CreateAllRelations
'    Set rel = db.CreateRelation(Name:="[rel.Name]", Table:="[rel.tblDataHeader]", ForeignTable:="[rel.tblDataDetail]", Attributes:=[rel.Attributes])
'        rel.Fields.Append rel.CreateField("[fld.Name for relation]")
'        rel.Fields("[fld.RECORD_NUMBER for relation]").ForeignName = "[fld.RECORD_NUMBER for relation]"
'        db.Relations.Append rel

    db.Close
    DoCmd.Close acForm, "frmDateRangeForDataArchive"
   
    Set db = CurrentDb
   
    DoCmd.SetWarnings False
        DoCmd.OpenQuery "delqryRecordsToArchive"
    DoCmd.SetWarnings True
        Else
        Exit Sub
    End If

End Sub

Private Sub Form_Open(Cancel As Integer)

    Me.cmdFocus.SetFocus

End Sub

Private Function CreateRelation(tblDataHeader As String, _
                                RECORD_NUMBER As String, _
                                tblDataDetail As String, _
                                RECORD_NUMBER As String) As Boolean
On Error GoTo ErrHandler

    Dim db As DAO.Database
    Dim newRelation As DAO.Relation
    Dim relatingField As DAO.Field
    Dim RECORD_NUMBER As String
   
    relationUniqueName = tblDataHeader + "_" + RECORD_NUMBER + _
                         "__" + tblDataDetail + "_" + RECORD_NUMBER
   
    Set db = CurrentDb()
   
    'Arguments for CreateRelation(): any unique name,
    'primary table, related table, attributes.
    Set newRelation = db.CreateRelation(relationUniqueName, _
                            tblDataHeader, tblDataDetail)
    'The field from the primary table.
    Set relatingField = newRelation.CreateField(RECORD_NUMBER)
    'Matching field from the related table.
    relatingField.ForeignName = RECORD_NUMBER
    'Add the field to the relation's Fields collection.
    newRelation.Fields.Append RECORD_NUMBER
    'Add the relation to the database.
    db.Relations.Append newRelation
   
    Set db = Nothing
   
    CreateRelation = True
       
Exit Function

ErrHandler:
    Debug.Print Err.Description + " (" + relationUniqueName + ")"
    CreateRelation = False
End Function

Public Function CreateAllRelations()

    Dim db As DAO.Database
    Dim totalRelations As Integer
    Dim i As Integer
   
    Set db = CurrentDb()
    totalRelations = db.Relations.Count
    If totalRelations > 0 Then
        For i = totalRelations - 1 To 0 Step -1
            db.Relations.Delete (db.Relations(i).Name)
        Next i
        Debug.Print Trim(Str(totalRelations)) + " Relationships deleted!"
    End If
   
    Debug.Print "Creating Relations..."
   

    Debug.Print CreateRelation("tblDataHeader", "RECORD_NUMBER", _
                               "tblDataDetail", "RECORD_NUMBER")
   

   
    totalRelations = db.Relations.Count
    Set db = Nothing
   
    Debug.Print Trim(Str(totalRelations)) + " Relationships created!"
    Debug.Print "Completed!"
End Function
Rey Obrero (Capricorn1)Commented:
READ the COMMENTS.
SteveL13Author Commented:
I'm still trying to copy the relationships in the new database.  Here is the code I'm trying to use:

    Dim fld As Field
    
    Set rel = db.Relations("reltblDataDetailtblDataHeader")
    
    Set rel = db.CreateRelation("tblDataHeader", "tblDataHeader", "tblDataDetail", dbRelationUpdateCascade Or dbRelationDeleteCascade)
    
    Set fld = rel.CreateField("RECORD_NUMBER")
    fld.ForeignName = "RECORD_NUMBER"
    rel.Fields.Append fld

    db.Relations.Append rel

    Set fld = Nothing
    Set rel = Nothing

Open in new window

But it isn't working.

And here is the entire onclick code of the command button that executes all this code: (everything works fine when I comment out the above pasted code.

Private Sub cmdArchiveTables_Click()

    If IsNull(Me.txtDate) Then
        MsgBox "You must enter a date."
        Me.txtDate.SetFocus
        Exit Sub
    End If

    If MsgBox("This function will archive data records per the date range you have specified.  Please be sure to create a backup file copy of your current working database before proceeding.  Do you wish to continue??", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then

    Dim ws As Workspace
    Dim db As Database
    Dim LFilename As String
    Dim tblDataHeader As Object
    Dim tblDataDetail As Object
    Dim rel As DAO.Relation

   'Get default Workspace
    Set ws = DBEngine.Workspaces(0)

   'Path and file name for new mdb file
    LFilename = Me.txtFileNameAndLocation & ".accdb"
    
'    MsgBox Me.txtFileNameAndLocation & ".accdb"

   'Make sure there isn't already a file with the name of the new database
    If Dir(LFilename) <> "" Then Kill LFilename

   'Create a new accdb file
    Set db = ws.CreateDatabase(LFilename, dbLangGeneral)

   'Export tables to new database
    DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "qryHeaderRecordsToArchive", "tblDataHeader", False
    DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "qryDetailRecordsToArchive", "tblDataDetail", False
    
    
    
    'Copy relationship between the two tables
    Dim fld As Field
    
    Set rel = db.Relations("reltblDataDetailtblDataHeader")
    
    Set rel = db.CreateRelation("tblDataHeader", "tblDataHeader", "tblDataDetail", dbRelationUpdateCascade Or dbRelationDeleteCascade)
    
    Set fld = rel.CreateField("RECORD_NUMBER")
    fld.ForeignName = "RECORD_NUMBER"
    rel.Fields.Append fld

    db.Relations.Append rel

    Set fld = Nothing
    Set rel = Nothing

    db.Close
    DoCmd.Close acForm, "frmDateRangeForDataArchive"
   
    Set db = CurrentDb
   
    DoCmd.SetWarnings False
        DoCmd.OpenQuery "delqryRecordsToArchive"
    DoCmd.SetWarnings True
        Else
        Exit Sub
    End If

End Sub

Open in new window

It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.