Results 1 to 2 of 2
  1. #1
    Join Date
    May 2006

    Unanswered: import vs Export objects from within a blank mdb

    1. Looking for code to create a new database on the fly.

    2. Then import all objects except the tables

    3. Import the tables with relationships from another mdb into the newly created mdb temporarily stored on c:\Temp

    All from within a third database.
    Compact and repair.

    Then replace the live version of the mdb with the newly created mdb - while verifiying that the live version is not in use - Maybe by checking for a .ldb file and if in use log the database name for later reference.

    The problem in a nutshell is that I need to be able to import the objects from 2 different databases into a 3rd newly created database from the active database tool I am creating to update the various versions of the databases. How do I modify this code to use the remote (newly created database) as the active database so that I may import the objects?

    Here is my current code:
    Option Compare Database
    Option Explicit
    Public Const mSourceFile = "C:\Development\MasterDev_ApDbms.mdb" '
    Public Const mFileTemp = "C:\Temp\"
    Public Const mFileApInfo = "\\abc\data\test\DB-Data\*.mdb
    Global nApno As String
    Global DestinationFile As String
    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 database to be considered for Version upgrades
        strSQL = "SELECT ApNo, ApDbms_Db" & _
                " FROM TA_AP IN '" & mFileApInfo & "'" & _
                " WHERE (((CurrentStatus)='Active') AND ((NotValid_FTCS)=0))"
        Set rs = curDB.OpenRecordset(strSQL)
        'Loops thru list of applicable tools
            Do Until rs.EOF
                nApno = rs.Fields("Apno")
                Debug.Print nApno
                'Sets filepath for current abc Number.
                strFile = rs.Fields("ApDbms_Db")
                'Determines if the abc Database exist in the directory (ApDbms_Db)
                If FileExists(strFile) = True Then
                    'Validates the current version for each abc.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:
                                Set oAcc = Nothing
                                CompactDatabase (DestinationFile)
                        End If
                End If
       On Error GoTo 0
       Exit Function
        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)
    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
        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. 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.
            'Strip any trailing slash, so Dir does not look inside the folder.
            Do While Right$(strFile, 1) = "\"
                strFile = Left$(strFile, Len(strFile) - 1)
        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
                TrailingSlash = varIn & "\"
            End If
        End If
    End Function
    Sub CompactDatabase(Path As String)
       SysCmd 602, Path, Path
    End Sub

  2. #2
    Join Date
    May 2006
    Here is the other half of my code.
    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 queries.
        For Each qd In db.QueryDefs
            strTDef = qd.Name
            DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acQuery, _
            strTDef, strTDef, False
        '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
                    cdb.Relations.Append nrel
                End With
            '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
        Set db = Nothing
        ImportDb = True
    End Function

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts