Importation/Exportation de Relations dans MS Access

Il me semble que vous pouvez utiliser une sauvegarde du fichier avant toute modification de restaurer les indices et les relations. Voici quelques 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

OriginalL'auteur Fionnuala

Merci pour l'extrait de code.
pour se débarrasser de votre 3284 erreur, j'ai changé un peu les choses.
Si vous copiez tous les index à partir de l'exemple de mdb et puis essayer de mettre les relations qu'elle lève une exception, car elle s'attend à aucune idexes pour relationshisps quand vous mettez les relations qu'elle met son propre index.
Étapes que j'ai suivies sont (à supposer cible.mdb et de la source.mdb):

1. D'exécuter ce code dans la cible.mdb supprimer tous les index et les relationsships
   frmo target.mdb en appelant ChangeTables
2. Appel AddIndexesFromBU source.mdb et d'utilisation
   
   Si ndxBU.Unique Puis tdf.Indexes.Append ndx Fin Si ce willput juste index Unique
3. appel AddRelationsFromBU source.mdb et de mettre tous relationsships
4. Appel de nouveau AddIndexesFromBU source.mdb et de la condition de changement de Si
   pas ndxBU.Unique Puis

J'ai également ajouté erreur piège de même que AddRelationsFromBU dans AddIndexesFromBU et resume next pour si sna d'autre

Cela a fonctionné pour moi.

OriginalL'auteur Vivek