Import Access Objects from 1 databse into another mdb other than active mdb (1 Viewer)

kfschaefer

Registered User.
Local time
Yesterday, 17:05
Joined
Oct 10, 2008
Messages
58
I am attempting to create a new database, then import Access objects into the newly created mdb from two different databases, while working in a third database.

I need to recreate database so that I may push out changes to duplicate copies of the mdb where the data is different - I know many of you will say why not use FB and BE but that is not an option for me- this is what I have to work with. So I need to duplicate a mdb based on a Master Template.mdb. When structual changes are needed I make the changes in the template and then forced to manually export the changes. I would like to automate the process.
Here is what I have so far:

My problem is that I am unable to call the newly created mdb so that the import code will place the objects in the new mdb. What am I missing?

Karen
Code:
Option Compare Database
Option Explicit
Public Const mSourceFile = "C:\Development\MasterDev_ApDbms.mdb" Public Const mFileTemp = "C:\Temp\"
Public Const mFileApInfo = "\\database name
Global nApno As String
Global DestinationFile As String
'---------------------------------------------------------------------------------------
' Procedure : ExportImport
' DateTime  : 12/14/2011 08:54
' Purpose   : Export database objects for version control of Airplane Databases.
'---------------------------------------------------------------------------------------
Public Function ExportImport()
Dim strSQL As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim strSQL3 As String
'Dim nApno As String
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim rs3 As DAO.Recordset
Dim strTbl  As String
Dim strFile  As String
Dim SourceFile As String
'Dim DestinationFile As String
Dim curDB As DAO.Database
Dim oAcc As Access.Application
'Dim obj As AccessObject, dbs As Object
 
   On Error GoTo ExportImport_Error
    Set curDB = CurrentDb()
    'Creates list of Airplane's database to be considered for Version upgrades
    strSQL = "SELECT ApNo, ApDbms_Db" & _
            " FROM TA_AirplaneInfo IN '" & mFileApInfo & "'" & _
            " WHERE (((CurrentStatus)='Active') AND ((NotValid_FTCS)=0))"
 
    Set rs = curDB.OpenRecordset(strSQL)
 
    'Loops thru list of applicable Airplanes
    rs.MoveFirst
        Do Until rs.EOF
            nApno = rs.Fields("Apno")
 
            Debug.Print nApno
 
            'Sets filepath for current Airplane Number.
            strFile = rs.Fields("ApDbms_Db")
 
            'Determines if the Airplane Database exist in the directory (ApDbms_Db)
            If FileExists(strFile) = True Then
 
                'Validates the current version for each Airplane.mdb & if greater the ver 4, then Update database objects and versions.
                strSQL2 = "SELECT Max(RevMaj) as Rev" & _
                            " FROM TS_DB_Revisions IN '" & strFile & "'"
 
                Set rs2 = curDB.OpenRecordset(strSQL2)
            Debug.Print rs2.Fields("Rev")
                    If rs2.Fields("Rev") > 4 Then
                        If Not rs2.EOF Then
                            DestinationFile = mFileTemp & nApno & "_ApDbms.mdb"
                            CreateNew (DestinationFile)
                            Set oAcc = OpenRemoteDatabase(DestinationFile)
'                            ImportDb (mSourceFile)
                        End If
                        '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
                            'When you're finished with the oAcc object, be sure to cleanup correctly:
                            oAcc.CloseCurrentDatabase
                            oAcc.Quit
                            Set oAcc = Nothing
 
                            CompactDatabase (DestinationFile)
                        '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
                    End If
            End If
               rs.MoveNext
        Loop
   On Error GoTo 0
   Exit Function
ExportImport_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ExportImport of Module modUpdate"
 
End Function
Public Sub CreateNew(ByVal DbPathName As String)
      Dim db As Database
         ' Create the database.
         Set db = CreateDatabase(DbPathName, dbLangGeneral)
        ImportDb (mSourceFile)
         db.Close
End Sub
 
Function CreateNewMDBFile(LFilename As String)
    Dim ws As Workspace
    Dim db As Database
    'Dim LFilename As String
    'Get default Workspace
    Set ws = DBEngine.Workspaces(0)
    'Path and file name for new mdb file
    LFilename = "c:\NewDB.mdb"
    'Make sure there isn't already a file with the name of the new database
    If Dir(LFilename) <> "" Then Kill LFilename
    'Create a new mdb file
    Set db = ws.CreateDatabase(LFilename, dbLangGeneral)
    'For lookup tables, export both table definition and data to new mdb file
    DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "Lookup Table1", "Lookup Table1", False
    'For data entry tables, export only table definition to new mdb file
    DoCmd.TransferDatabase acExport, "Microsoft Access", LFilename, acTable, "DataEntry Table1", "DataEntry Table1", True
    db.Close
    Set db = Nothing
End Function
 
Function OpenRemoteDatabase(PathToDatabase As String) As Access.Application
Dim o As Access.Application
Set o = New Access.Application
    o.OpenCurrentDatabase PathToDatabase
 
    Set OpenRemoteDatabase = o
    ImportDb (mSourceFile)
 
End Function
Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
    'Purpose:   Return True if the file exists, even if it is hidden.
    'Arguments: strFile: File name to look for. Current directory searched if no path included.
    '           bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
    'Note:      Does not look inside subdirectories for the file.
    'Author:    Allen Browne. [URL]http://allenbrowne.com[/URL] June, 2006.
    Dim lngAttributes As Long
    'Include read-only files, hidden files, system files.
    lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)
    If bFindFolders Then
        lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
    Else
        'Strip any trailing slash, so Dir does not look inside the folder.
        Do While Right$(strFile, 1) = "\"
            strFile = Left$(strFile, Len(strFile) - 1)
        Loop
    End If
    'If Dir() returns something, the file exists.
    On Error Resume Next
    FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function
Function FolderExists(strPath As String) As Boolean
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0 Then
        If Right(varIn, 1) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function
Sub CompactDatabase(Path As String)
   SysCmd 602, Path, Path
End Sub
Sub AllQueries()
    Dim obj As AccessObject, dbs As Object
    Dim oAcc As Access.Application
DestinationFile = mFileTemp & nApno & "_ApDbms.mdb"
Set oAcc = OpenRemoteDatabase(DestinationFile)
 
    Set dbs = oAcc.Application.CurrentData
    ' Search for open AccessObject objects in AllQueries collection.
    For Each obj In dbs.AllQueries
        If obj.IsLoaded = False Then
            dbs.DoCmd.TransferDatabase acImport, "Microsoft Access", mSourceFile, acQuery
            Debug.Print obj.Name
        End If
    Next obj
End Sub
Sub AllForms()
    Dim obj As AccessObject, dbs As Object
    Set dbs = Application.CurrentProject
    ' Search for open AccessObject objects in AllForms collection.
    For Each obj In dbs.AllForms
        If obj.IsLoaded = True Then
            ' Print name of obj.
            Debug.Print obj.Name
        End If
    Next obj
End Sub
Sub AllMacros()
    Dim obj As AccessObject, dbs As Object
    Set dbs = Application.CurrentProject
    ' Search for open AccessObject objects in AllMacros collection.
    For Each obj In dbs.AllMacros
        If obj.IsLoaded = True Then
            ' Print name of obj.
            Debug.Print obj.Name
        End If
    Next obj
End Sub
Sub AllModules()
    Dim obj As AccessObject, dbs As Object
    Set dbs = Application.CurrentProject
    ' Search for open AccessObject objects in AllModules collection.
    For Each obj In dbs.AllModules
        If obj.IsLoaded = True Then
            ' Print name of obj.
            Debug.Print obj.Name
        End If
    Next obj
End Sub
 
Public Function ImportDb(strPath As String) As Boolean
Dim db As Database 'Database to import
Dim td As TableDef 'Tabledefs in db
Dim strTDef As String 'Name of table or query to import
Dim qd As QueryDef 'Querydefs in db
Dim doc As Document 'Documents in db
Dim strCntName As String 'Document container name
Dim x As Integer 'For looping
Dim cntContainer As Container 'Containers in db
Dim strDocName As String 'Name of document
Dim intConst As Integer
Dim cdb As Database 'Current Database
Dim rel As Relation 'Relation to copy
Dim nrel As Relation 'Relation to create
Dim strRName As String 'Copied relation's name
Dim strTName As String 'Relation Table name
Dim strFTName As String 'Relation Foreign Table name
Dim varAtt As Variant 'Attributes of relation
Dim fld As Field 'Field(s) in relation to copy
Dim strFName As String 'Name of field to append
Dim strFFName As String 'Foreign name of field to append
On Error Resume Next
'Open database which contains objects to import.
Set db = DBEngine.Workspaces(0).OpenDatabase(strPath, True)
 
    'Import tables from specified Access database.
'    For Each td In db.TableDefs
'        strTDef = td.Name
'        If Left(strTDef, 4) <> "MSys" Then
'            DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acTable, _
'            strTDef, strTDef, False
'        End If
'    Next
 
    'Import queries.
    For Each qd In db.QueryDefs
        strTDef = qd.Name
        DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acQuery, _
        strTDef, strTDef, False
    Next
 
    'Copy relationships to current database.
    Set cdb = CurrentDb
 
        For Each rel In db.Relations
            With rel
 
                'Get properties of relation to copy.
                strRName = .Name
                strTName = .Table
                strFTName = .ForeignTable
                varAtt = .Attributes
 
                'Create relation in current db with same properties.
                Set nrel = cdb.CreateRelation(strRName, strTName, strFTName, varAtt)
 
                For Each fld In .Fields
                    strFName = fld.Name
                    strFFName = fld.ForeignName
                    nrel.Fields.Append nrel.CreateField(strFName)
                    nrel.Fields(strFName).ForeignName = strFFName
                Next
                cdb.Relations.Append nrel
            End With
        Next
 
        'Loop through containers and import all documents.
        For x = 1 To 4
            Select Case x
                Case 1
                    strCntName = "Forms"
                    intConst = acForm
                Case 2
                    strCntName = "Reports"
                    intConst = acReport
                Case 3
                    strCntName = "Scripts"
                    intConst = acMacro
                Case 4
                    strCntName = "Modules"
                    intConst = acModule
            End Select
 
            Set cntContainer = db.Containers(strCntName)
 
            For Each doc In cntContainer.Documents
                strDocName = doc.Name
                DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, intConst, _
                strDocName, strDocName
 
            'Debug.Print strDocName
            'for debugging, will list document names in debug window.
            Next doc
        Next x
 
    'Clean up variables to recover memory.
    Set fld = Nothing
    Set nrel = Nothing
    Set rel = Nothing
    Set cdb = Nothing
    Set td = Nothing
    Set qd = Nothing
    Set cntContainer = Nothing
 
    db.Close
    Set db = Nothing
 
    ImportDb = True
End Function
 

Users who are viewing this thread

Top Bottom