vba 在 MS Access 中导入/导出关系

Importing/Exporting Relationships in MS Access

提问by lamcro

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:

我有几个具有确切表结构的 mdb 文件。我必须将主表的主键从自动编号更改为编号，这意味着我必须：

1. Drop the all the relationships the main table has
2. Change the main table
3. Create the relationships again,... for all the tables.

1. 删除主表的所有关系
2. 更改主表
3. 再次创建关系，...为所有表。

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?

我相信这可以通过一些宏/vb 代码来完成。有没有人有我可以使用的例子？

Thanks.

谢谢。

回答by Patrick Cuff

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.):

以下函数将打印出所有关系的元数据。将此更改为以您喜欢的任何格式（CSV、制表符分隔、XML 等）保存到文件：

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).

由于时间限制，错误处理和 IO 被省略（必须让孩子们上床睡觉）。

Hope this helps.

希望这可以帮助。

回答by Jakub M.

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

根据@Patrick Cuff 的回答，我创建了一对脚本：一个导出到 xml，另一个读取此 xml 并将其解析到数据库中

VBScript for exporting relationships from MsAccess into XML

用于将关系从 MsAccess 导出到 XML 的 VBScript

'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

用于将关系从 XML 导入 MsAccess 的 VBScript

'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 oApplicationparameter

只是为了澄清预期传递给oApplication参数的内容

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 Applicationobject everywhere in the code where oApplicationis being used.

如果您是从 VBA 而不是 VBScript 运行它，您可以删除参数，并在使用oApplication的代码中的任何地方删除常规Application对象。

---

---

I got started to work on this code as I needed to implement a Version Control on a very complicated MsAccess project. This postgot me moving, there are also some good advices on how to export/import other parts of the MsAccess project.

我开始处理这段代码，因为我需要在一个非常复杂的 MsAccess 项目上实现版本控制。这篇文章让我感动，还有一些关于如何导出/导入 MsAccess 项目其他部分的好建议。

回答by Fionnuala

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

回答by Vivek

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):

感谢您的代码片段。为了摆脱你的 3284 错误，我改变了一些东西。如果您从示例 mdb 复制所有索引，然后尝试放置关系，它会引发异常，因为当您放置关系时，它不期望关系的 idexes 放置自己的索引。我遵循的步骤是（假设 target.mdb 和 source.mdb）：

1. Run this code in target.mdb remove all indexes and relationsships frmo target.mdbby calling ChangeTables
2. Call AddIndexesFromBUsource.mdb and use condition
   If ndxBU.UniqueThen tdf.Indexes.Append ndxEnd If this willput just Unique index
3. call AddRelationsFromBU source.mdband put all relationsships
4. Call again AddIndexesFromBU source.mdb and change condition to If not ndxBU.UniqueThen

1. 在 target.mdb 中运行此代码target.mdb通过调用 ChangeTables删除所有索引和关系
2. 调用AddIndexesFromBUsource.mdb 并使用条件
   If ndxBU.UniqueThen tdf.Indexes.Append ndxEnd If 这将只输入唯一索引
3. 调用 AddRelationsFromBUsource.mdb并放置所有关系
4. 再次调用 AddIndexesFromBU source.mdb 并将条件更改为 If not ndxBU.UniqueThen

I have also added error trap same as AddRelationsFromBU in AddIndexesFromBU and resume next for if ans else

我还在 AddIndexesFromBU 中添加了与 AddRelationsFromBU 相同的错误陷阱，然后继续 if an else

This worked for me.

这对我有用。