Εισαγωγή / Εξαγωγή Σχέσεις στην MS Access

ψήφοι
4

Έχω ένα ζευγάρι από τα αρχεία mdb με την ακριβή δομή του πίνακα. Πρέπει να αλλάξω το πρωτεύον κλειδί του κύριου πίνακα από αυτόματης αρίθμησης σε αριθμό σε όλα αυτά, πράγμα που σημαίνει ότι πρέπει να:

  1. Πέτα τα όλα τις σχέσεις ο κύριος πίνακας έχει
  2. Αλλάξτε τον κύριο πίνακα
  3. Δημιουργήστε τις σχέσεις και πάλι, ... για όλους τους πίνακες.

Υπάρχει κάποιος τρόπος εξαγωγής των σχέσεων από το ένα αρχείο και εισαγωγή τους σε όλα τα υπόλοιπα εκεί;

Είμαι βέβαιος ότι αυτό μπορεί να γίνει με κάποια μακρο / κωδικό vb. Υπάρχει κάποιος που έχει ένα παράδειγμα θα μπορούσα να χρησιμοποιήσω;

Ευχαριστώ.

Δημοσιεύθηκε 10/12/2008 στις 00:48
πηγή χρήστη
Σε άλλες γλώσσες...                            


4 απαντήσεις

ψήφοι
11

Δεν είναι μια ολοκληρωμένη λύση, αλλά αυτό μπορεί να πας ...

Η ακόλουθη λειτουργία θα εκτυπώσετε τα μεταδεδομένα για όλες τις σχέσεις. Αλλάξτε αυτό για να αποθηκεύσετε σε ένα αρχείο σε οποιαδήποτε μορφή προτιμάτε (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

Αυτή η λειτουργία θα ρίξει όλες τις σχέσεις στη βάση δεδομένων:

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

Η λειτουργία αυτή θα δημιουργήσει μια σχέση. Θα πρέπει να επαναλάβει πάνω από το αρχείο των αποθηκευμένων δεδομένων σχέσης.

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

αντιμετώπιση των λαθών και IO παραλείπεται, λόγω του περιορισμένου χρόνου (το gotta βάλει τα παιδιά για ύπνο).

Η ελπίδα αυτό βοηθά.

Απαντήθηκε 10/12/2008 στις 03:40
πηγή χρήστη

ψήφοι
1

Με βάση την απάντηση @Patrick σφαλιάρα του, έχω δημιουργήσει ένα ζευγάρι σενάρια: ένα εξαγωγή σε XML, άλλοι την ανάγνωση αυτού του xml και την ανάλυση του σε βάση δεδομένων

VBScript για την εξαγωγή σχέσεων από MsAccess σε 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 για την εισαγωγή σχέσεις σε MsAccess από 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

Σημειώσεις

Ακριβώς για να διευκρινίσει τι αναμένεται να περάσει σε oApplication παράμετρο

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

Σε περίπτωση που χρησιμοποιείτε αυτή από την VBA αντί της VBScript, μπορείτε να διαγράψετε την παράμετρο και μόλις την τακτική Εφαρμογή αντικείμενο οπουδήποτε στον κώδικα όπου oApplication χρησιμοποιείται.


Πήρα άρχισε να εργάζεται για αυτόν τον κωδικό, τι χρειάζεται για να εφαρμόσει Ελέγχου Έκδοση σε ένα πολύ περίπλοκο έργο MsAccess. Αυτή η θέση πήρε με τη μετακίνηση, υπάρχουν και κάποιες καλές συμβουλές για το πώς να εξαγωγών / εισαγωγών άλλα μέρη του έργου MsAccess.

Απαντήθηκε 16/02/2016 στις 16:18
πηγή χρήστη

ψήφοι
1

Εμφανίζεται σε μένα ότι μπορείτε να χρησιμοποιήσετε ένα αντίγραφο ασφαλείας του αρχείου γίνεται πριν από κάθε αλλαγή για την αποκατάσταση των δεικτών και των σχέσεων. Εδώ είναι μερικές σημειώσεις.

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
Απαντήθηκε 10/12/2008 στις 05:27
πηγή χρήστη

ψήφοι
0

Ευχαριστώ για απόσπασμα κώδικα. για να απαλλαγούμε από το σφάλμα 3284 σας έχω αλλάξει μερικά πράγματα. Εάν αντιγράψετε όλα τα ευρετήρια από mdb δείγματος και στη συνέχεια προσπαθήστε να βάλετε τις σχέσεις ρίχνει μια εξαίρεση, καθώς δεν αναμένει idexes για relationshisps όταν βάζετε τις σχέσεις βάζει τη δική τους δείκτες της. Βήματα που ακολουθούνται είναι (υποθέτουμε target.mdb και source.mdb):

  1. Εκτελέστε αυτόν τον κώδικα στο target.mdb αφαιρέσετε όλα τα ευρετήρια και relationsships frmo target.mdbκαλώντας ChangeTables
  2. Καλέστε AddIndexesFromBUsource.mdb και να χρησιμοποιήσετε την κατάσταση
    Αν ndxBU.UniqueΣτη συνέχεια tdf.Indexes.Append ndx End If αυτό willput απλά μοναδικό ευρετήριο
  3. καλέστε AddRelationsFromBU source.mdbκαι να θέσει όλα τα relationsships
  4. Καλέστε ξανά AddIndexesFromBU source.mdb και να αλλάξει την κατάσταση σε περίπτωση που δεν ndxBU.UniqueΤότε

Έχω προσθέσει επίσης παγίδα σφάλματος ίδιο με AddRelationsFromBU στην AddIndexesFromBU και να συνεχίσετε την επόμενη γιατί αν ans άλλο

Αυτό λειτούργησε για μένα.

Απαντήθηκε 16/04/2010 στις 08:10
πηγή χρήστη

Cookies help us deliver our services. By using our services, you agree to our use of cookies. Learn more