Option Compare Database

Option Explicit

Public Function ImportDb(strPath As String) As Boolean

On Error Resume Next

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

'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