Importing/Exporting Relationships - vba

Question

I have a couple of mdb files with the exact table structure. I have to change the primary key of the main table from autonumber to number in all of them, which means I have to:
Drop the all the relationships the main table has
Change the main table
Create the relationships again,... for all the tables.
Is there any way to export the relationships from one file and importing them to all the rest?
I am sure this can be done with some macro/vb code. Does anyone has an example I could use?
Thanks.

Answer 1

Not a complete solution, but this may get you going...
The following function will print out the metadata for all relationships. Change this to save to a file in whatever format you prefer (CSV, tab delimited, XML, etc.):
Function PrintRelationships()
For Each rel In CurrentDb.Relations
With rel
Debug.Print "Name: " & .Name
Debug.Print "Attributes: " & .Attributes
Debug.Print "Table: " & .Table
Debug.Print "ForeignTable: " & .ForeignTable
Debug.Print "Fields:"
For Each fld In .Fields
Debug.Print "Field: " & fld.Name
Next
End With
Next
End Function
This function will drop all the relationships in the database:
Function DropRelationships()
With CurrentDb
For Each rel In .Relations
.Relations.Delete Name:=rel.Name
Next
End With
End Function
This function will create a relationship. You'll have to iterate over the file of saved relationship data.
Function CreateRelationships()
With CurrentDb
Set rel = .CreateRelation(Name:="[rel.Name]", Table:="[rel.Table]", ForeignTable:="[rel.FireignTable]", Attributes:=[rel.Attributes])
rel.Fields.Append rel.CreateField("[fld.Name for relation]")
rel.Fields("[fld.Name for relation]").ForeignName = "[fld.Name for relation]"
.Relations.Append rel
End With
End Function
Error handling and IO omitted due to time constraints (gotta put the kids to bed).
Hope this helps.

Answer 2

Based on #Patrick Cuff's answer, I have created a pair of scripts: one exporting into xml, other reading this xml and parsing it into the database
VBScript for exporting relationships from MsAccess into XML
'supply the Access Application object into this function and path to file to which the output should be written
Function ExportRelationships(oApplication, sExportpath)
Dim relDoc, myObj
Set relDoc = CreateObject("Microsoft.XMLDOM")
relDoc.appendChild relDoc.createElement("Relations") 'create root xml element
'loop though all the relations
For Each myObj In oApplication.CurrentDb.Relations
If Not Left(myObj.Name, 4) = "MSys" Then 'exclude system relations
Dim relName, relAttrib, relTable, relFoTable, fld
relDoc.childNodes(0).appendChild relDoc.createElement("Relation")
Set relName = relDoc.createElement("Name")
relName.Text = myObj.Name
relDoc.childNodes(0).lastChild.appendChild relName
Set relAttrib = relDoc.createElement("Attributes")
relAttrib.Text = myObj.Attributes
relDoc.childNodes(0).lastChild.appendChild relAttrib
Set relTable = relDoc.createElement("Table")
relTable.Text = myObj.Table
relDoc.childNodes(0).lastChild.appendChild relTable
Set relFoTable = relDoc.createElement("ForeignTable")
relFoTable.Text = myObj.ForeignTable
relDoc.childNodes(0).lastChild.appendChild relFoTable
'in case the relationship works with more fields
For Each fld In myObj.Fields
Dim lf, ff
relDoc.childNodes(0).lastChild.appendChild relDoc.createElement("Field")
Set lf = relDoc.createElement("Name")
lf.Text = fld.Name
relDoc.childNodes(0).lastChild.lastChild.appendChild lf
Set ff = relDoc.createElement("ForeignName")
ff.Text = fld.ForeignName
relDoc.childNodes(0).lastChild.lastChild.appendChild ff
Next
End If
Next
relDoc.insertBefore relDoc.createProcessingInstruction("xml","version='1.0'"), relDoc.childNodes(0)
relDoc.Save sExportpath
End Function
VBScript for importing relationships into MsAccess from XML
'supply the Access Application object into this function and path to file from which the input should be read
Function ImportRelationships(oApplication, sImportpath)
Dim relDoc, myObj
Set relDoc = CreateObject("Microsoft.XMLDOM")
relDoc.Load(sImportpath)
Dim xmlRel, xmlField, accessRel, relTable, relName, relFTable, relAttr, i
'loop through every Relation node inside .xml file
For Each xmlRel in relDoc.selectNodes("/Relations/Relation")
relName = xmlRel.selectSingleNode("Name").Text
relTable = xmlRel.selectSingleNode("Table").Text
relFTable = xmlRel.selectSingleNode("ForeignTable").Text
relAttr = xmlRel.selectSingleNode("Attributes").Text
'remove any possible conflicting relations or indexes
On Error Resume next
oApplication.CurrentDb.Relations.Delete (relName)
oApplication.CurrentDb.TableDefs(relTable).Indexes.Delete(relName)
oApplication.CurrentDb.TableDefs(relFTable).Indexes.Delete(relName)
On Error Goto 0
'create the relationship object
Set accessRel = oApplication.CurrentDb.CreateRelation(relName, relTable, relFTable, relAttr)
'in case the relationship works with more fields
For Each xmlField In xmlRel.selectNodes("Field")
accessRel.Fields.Append accessRel.CreateField(xmlField.selectSingleNode("Name").Text)
accessRel.Fields(xmlField.selectSingleNode("Name").Text).ForeignName = xmlField.selectSingleNode("ForeignName").Text
Next
'and finally append the newly created relationship to the database
oApplication.CurrentDb.Relations.Append accessRel
Next
End Function
Notes
Just to clarify what is expected to be passed into oApplication parameter
Set oApplication = CreateObject("Access.Application")
oApplication.NewCurrentDatabase path 'new database
oApplication.OpenCurrentDatabase path 'existing database
In case you are running this from VBA instead of VBScript, you can delete the parameter and just the regular Application object everywhere in the code where oApplication is being used.
I got started to work on this code as I needed to implement a Version Control on a very complicated MsAccess project. This post got me moving, there are also some good advices on how to export/import other parts of the MsAccess project.

Answer 3

It occurs to me that you can use a backup of the file made before any changes to restore the indexes and relations. Here are some notes.
Sub RunExamples()
Dim strCopyMDB As String
Dim fs As FileSystemObject
Dim blnFound As Boolean
Dim i
' This code is not intended for general users, it is sample code built '
' around the OP '
'You will need a reference to the Microsoft DAO 3.x Object Library '
'This line causes an error, but it will run '
'It is not suitable for anything other than saving a little time '
'when setting up a new database '
Application.References.AddFromFile ("C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll")
'You must first create a back-up copy '
Set fs = CreateObject("Scripting.FileSystemObject")
strCopyMDB = CurrentProject.Path & "\c.mdb"
blnFound = fs.FileExists(strCopyMDB)
i = 0
Do While blnFound
strCopyMDB = CurrentProject.Path & "\c" & i & ".mdb"
blnFound = fs.FileExists(strCopyMDB)
Loop
fs.CopyFile CurrentProject.FullName, strCopyMDB
ChangeTables
AddIndexesFromBU strCopyMDB
AddRelationsFromBU strCopyMDB
End Sub
Sub ChangeTables()
Dim db As Database
Dim tdf As DAO.TableDef
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim ndx As DAO.Index
Dim i
Set db = CurrentDb
'In order to programmatically change an autonumber, '
'it is necessary to delete any relationships that '
'depend on it. '
'When deleting from a collection, it is best '
'to iterate backwards. '
For i = db.Relations.Count - 1 To 0 Step -1
db.Relations.Delete db.Relations(i).Name
Next
'The indexes must also be deleted or the '
'number cannot be changed. '
For Each tdf In db.TableDefs
If Left(tdf.Name, 4) <> "Msys" Then
For i = tdf.Indexes.Count - 1 To 0 Step -1
tdf.Indexes.Delete tdf.Indexes(i).Name
Next
tdf.Indexes.Refresh
For Each fld In tdf.Fields
'If the field is an autonumber, '
'use code supplied by MS to change the type '
If (fld.Attributes And dbAutoIncrField) Then
AlterFieldType tdf.Name, fld.Name, "Long"
End If
Next
End If
Next
End Sub
Sub AddIndexesFromBU(MDBBU)
Dim db As Database
Dim dbBU As Database
Dim tdf As DAO.TableDef
Dim tdfBU As DAO.TableDef
Dim ndx As DAO.Index
Dim ndxBU As DAO.Index
Dim i
Set db = CurrentDb
'This is the back-up made before starting '
Set dbBU = OpenDatabase(MDBBU)
For Each tdfBU In dbBU.TableDefs
'Skip system tables '
If Left(tdfBU.Name, 4) <> "Msys" Then
For i = tdfBU.Indexes.Count - 1 To 0 Step -1
'Get each index from the back-up '
Set ndxBU = tdfBU.Indexes(i)
Set tdf = db.TableDefs(tdfBU.Name)
Set ndx = tdf.CreateIndex(ndxBU.Name)
ndx.Fields = ndxBU.Fields
ndx.IgnoreNulls = ndxBU.IgnoreNulls
ndx.Primary = ndxBU.Primary
ndx.Required = ndxBU.Required
ndx.Unique = ndxBU.Unique
' and add it to the current db '
tdf.Indexes.Append ndx
Next
tdf.Indexes.Refresh
End If
Next
End Sub
Sub AddRelationsFromBU(MDBBU)
Dim db As Database
Dim dbBU As Database
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim relBU As DAO.Relation
Dim i, j, f
On Error GoTo ErrTrap
Set db = CurrentDb
'The back-up again '
Set dbBU = OpenDatabase(MDBBU)
For i = dbBU.Relations.Count - 1 To 0 Step -1
'Get each relationship from bu '
Set relBU = dbBU.Relations(i)
Debug.Print relBU.Name
Set rel = db.CreateRelation(relBU.Name, relBU.Table, relBU.ForeignTable, relBU.Attributes)
For j = 0 To relBU.Fields.Count - 1
f = relBU.Fields(j).Name
rel.Fields.Append rel.CreateField(f)
rel.Fields(f).ForeignName = relBU.Fields(j).ForeignName
Next
'For some relationships, I am getting error'
'3284 Index already exists, which I will try'
'and track down tomorrow, I hope'
'EDIT: Apparently this is due to Access creating hidden indexes
'and tracking these down would take quite a bit of effort
'more information can be found in this link:
'http://groups.google.ie/group/microsoft.public.access/browse_thread/thread/ca58ce291bdc62df?hl=en&ie=UTF-8&q=create+relation+3284+Index+already+exists
'It is an occasional problem, so I've added an error trap
'Add the relationship to the current db'
db.Relations.Append rel
Next
ExitHere:
Exit Sub
ErrTrap:
If Err.Number = 3284 Then
Debug.Print relBU.Name, relBU.Table, relBU.ForeignTable, relBU.Attributes
Resume Next
Else
'this is not a user sub, so may as well ... '
Stop
End If
End Sub
Sub AlterFieldType(TblName As String, FieldName As String, _
NewDataType As String)
'http://support.microsoft.com/kb/128016'
Dim db As Database
Dim qdf As QueryDef
Set db = CurrentDb()
' Create a dummy QueryDef object.'
Set qdf = db.CreateQueryDef("", "Select * from PROD1")
' Add a temporary field to the table.'
qdf.SQL = "ALTER TABLE [" & TblName & "] ADD COLUMN AlterTempField " & NewDataType
qdf.Execute
' Copy the data from old field into the new field.'
qdf.SQL = "UPDATE DISTINCTROW [" & TblName _
& "] SET AlterTempField = [" & FieldName & "]"
qdf.Execute
' Delete the old field.'
qdf.SQL = "ALTER TABLE [" & TblName & "] DROP COLUMN [" _
& FieldName & "]"
qdf.Execute
' Rename the temporary field to the old field's name.'
db.TableDefs("[" & TblName & "]").Fields("AlterTempField").Name = FieldName
End Sub

Answer 4

Thanks for code snippet.
to get rid of your 3284 error I have changed a few things.
If you copy all indexes from sample mdb and then try to put relationships it throws an exception as it expects no idexes for relationshisps when you put relationships it puts its own indexes.
Steps I followed are (assume target.mdb and source.mdb):
Run this code in target.mdb remove all indexes and relationsships
frmo target.mdb by calling ChangeTables
Call AddIndexesFromBU source.mdb and use condition
If ndxBU.Unique Then tdf.Indexes.Append ndx End If this willput just Unique index
call AddRelationsFromBU source.mdb and put all relationsships
Call again AddIndexesFromBU source.mdb and change condition to If
not ndxBU.Unique Then
I have also added error trap same as AddRelationsFromBU in AddIndexesFromBU and resume next for if ans else
This worked for me.