Problems running sample code.

[Antonio]

I am trying to run sample code to Import All Database
Object (298174-ACC200: Sample Code to Import All Database
Ojects)that I found in the Microsoft Knowledge Base
articles. I followed the steps as listed (made the
reference selections to DAO 3.6 Object Library, made sure
no Active X objects were selected, pasted the code into a
module window, On the view Menu Clicked "Immediate
Window", I typed in the path name to the database, and
hit enter. The instructions say that the
code "returns 'True' (or-1) if it runs succesfully", and
that is what happend, a "True" popped up, but nothing was
imported from the target database into the current
database. I dont know what I am doing wrong. Can anyone
give some suggestions on what to do if you get the
succesful "True", but nothing is imported...are there
things to check, de-select, etc?? Im not proficient at
VBA at all and would appreciate any help.
Here is the code that I pasted.

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

I click on "View" and then "Immediate Window", and then I
type in
?ImportDb("D:\Kazimiera Development\New and Improved
Kazimiera.mdb")
and i get
"True", but nothing shows up in the current database...
TIA

 

[SteveS]

Antonio,

The first thing I see is no error handling. Every time there is an
error, this line

On Error Resume Next

tells the code to continue at the line after the one that caused the
error. But you are not told there was an error. I added some basic (no
pun intended) error notification.

The reason that TRUE was returned in the immediate window (and will
ALWAYS return True as it is written now) is due to this line:

ImportDb = True

just above the 'End Function' line. In this case, the function ImportDb
return value is set to True whether or not there was an error.

Have you tried setting break points and running the code?


Here is the modified code. Copy it and paste it in your module.
Watch for line wrap; look for lines that look like this:

'*****this should be one line


'-------------------------

Option Compare Database

Option Explicit

Public Function ImportDb(strPath As String) As Boolean

'On Error Resume Next
On Error GoTo Err_ImportDb

Dim cdb As Database 'Current Database
Dim db As Database 'Database to import

Dim rel As Relation 'Relation to copy
Dim nrel As Relation 'Relation to create

Dim td As TableDef 'Tabledefs in db

Dim fld As Field 'Field(s) in relation to copy

Dim qd As QueryDef 'Querydefs in db

Dim cntContainer As Container 'Containers in db

Dim doc As Document 'Documents in db

Dim x As Integer 'For looping
Dim intConst As Integer

Dim strDocName As String 'Name of document
Dim strCntName As String 'Document container name
Dim strTDef As String 'Name of table or query to import
Dim strRName As String 'Copied relation's name
Dim strTName As String 'Relation Table name
Dim strFTName As String 'Relation Foreign Table name
Dim strFName As String 'Name of field to append
Dim strFFName As String 'Foreign name of field to append

Dim varAtt As Variant 'Attributes of relation

'set the return status
ImportDb = False

'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

'*****this should be one line
DoCmd.TransferDatabase acImport, "Microsoft Access", strPath,
acTable, strTDef, strTDef, False

End If
Next

'Import queries.
For Each qd In db.QueryDefs
strTDef = qd.Name

'*****this should be one line
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.

'*****this should be one line
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

'*****this should be one line
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

' Successful - return True
ImportDb = True

Exit_ImportDb:
'Clean up variables to recover memory.
Set fld = Nothing
Set nrel = Nothing
Set rel = Nothing
Set td = Nothing
Set qd = Nothing
Set cntContainer = Nothing

db.Close
Set db = Nothing
Set cdb = Nothing

Exit Sub

Err_ImportDb:
' tell them OOPs!
MsgBox "Error: " & Err.Number & " - " & Err.Description

Resume Exit_ImportDb

End Function
'-------------------------

HTH

Steve