modificar macro intentar importación importacion guardar guardada exportación exportacion especificación especificacion error ejecutar automaticamente vba ms-access access-vba table-relationships

vba - macro - Importación/exportación de relaciones en MS Access



error al intentar guardar la especificación de importación o exportación access (4)

No es una solución completa, pero esto puede hacer que empieces ...

La siguiente función imprimirá los metadatos para todas las relaciones. Cambie esto para guardarlo en un archivo en el formato que prefiera (CSV, delimitado por tabuladores, 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

Esta función eliminará todas las relaciones en la base de datos:

Function DropRelationships() With CurrentDb For Each rel In .Relations .Relations.Delete Name:=rel.Name Next End With End Function

Esta función creará una relación. Tendrás que iterar sobre el archivo de datos de relación guardados.

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

Manejo de errores y IO omitido debido a restricciones de tiempo (tengo que acostar a los niños).

Espero que esto ayude.

Tengo un par de archivos mdb con la estructura de tabla exacta. Tengo que cambiar la clave principal de la tabla principal de autonumber a number en todos ellos, lo que significa que tengo que:

  1. Deja todas las relaciones que tiene la tabla principal
  2. Cambiar la tabla principal
  3. Crea las relaciones nuevamente, ... para todas las tablas.

¿Hay alguna forma de exportar las relaciones de un archivo e importarlas a todo el resto?

Estoy seguro de que esto se puede hacer con algún código macro / vb. ¿Alguien tiene un ejemplo que podría usar?

Gracias.


Se me ocurre que puede usar una copia de seguridad del archivo realizado antes de cualquier cambio para restaurar los índices y las relaciones. Aquí hay algunas notas.

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


Basado en la respuesta de @Patrick Cuff, he creado un par de scripts: uno exportando a xml, otro leyendo este xml y analizándolo en la base de datos.

VBScript para exportar relaciones de MsAccess a 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 para importar relaciones en MsAccess desde 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

Notas

Solo para aclarar qué se espera que pase al parámetro oApplication

Set oApplication = CreateObject("Access.Application") oApplication.NewCurrentDatabase path ''new database oApplication.OpenCurrentDatabase path ''existing database

En el caso de que esté ejecutando esto desde VBA en lugar de VBScript, puede eliminar el parámetro y solo el objeto Aplicación regular en todas partes en el código donde se usa oApplication .

Empecé a trabajar en este código ya que necesitaba implementar un Control de versiones en un proyecto de MsAccess muy complicado. Esta publicación me puso en movimiento, también hay algunos buenos consejos sobre cómo exportar / importar otras partes del proyecto MsAccess.


Gracias por el fragmento de código. para deshacerse de su error 3284, he cambiado algunas cosas. Si copia todos los índices de la muestra mdb y luego intenta poner relaciones arroja una excepción, ya que no espera que existan idexes para las relacioneshispas, cuando pone relaciones pone sus propios índices. Los pasos que seguí son (supongamos target.mdb y source.mdb):

  1. Ejecute este código en target.mdb elimine todos los índices y relaciones frmo target.mdb llamando a ChangeTables
  2. Llamar AddIndexesFromBU source.mdb y usar condición
    Si ndxBU.Unique Then tdf.Indexes.Append ndx End If this willput solo Unique index
  3. llamar AddRelationsFromBU source.mdb y poner todas las relaciones
  4. Llame nuevamente AddIndexesFromBU source.mdb y cambie la condición a If not ndxBU.Unique Then

También he agregado la trampa de error igual que AddRelationsFromBU en AddIndexesFromBU y lo reanudo a continuación si ans ans else

Esto funcionó para mí.