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
    rs.MoveFirst
        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:
                            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. http://allenbrowne.com 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

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
    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