JPaulo tentei usar sua fncao mas esta dando
A sequinte mensagem
Erro de compilacao
Metodos ou membro de dados nao encontrados
Option Explicit
Public Function ImportaTodasTabelas(strPath As String) As Boolean
On Error Resume Next
'codigo da Microsoft adaptado por JPaulo
Maximo Access
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 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
Set db = DBEngine.Workspaces(0).OpenDatabase(strPath, True)
For Each td In db.TableDefs
strTDef = td.Name
If TableExists(td.Name) = True Then 'verifica se a tabela já existe
CurrentDb.TableDefs.Delete td.Name 'se existe deleta
If Left(strTDef, 4) <> "MSys" Then
' importa tabelas e relacionamentos
DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acTable, _
strTDef, strTDef, False
End If
End If
Next
Set cdb = CurrentDb
For Each rel In db.Relations
With rel
strRName = .Name
strTName = .Table
strFTName = .ForeignTable
varAtt = .Attributes
Set nrel = cdb.CreateRelation(strRName, strTName, strFTName, varAtt)
For Each fld In .Fields
strFName = fld.Name
strFFName = fld
.ForeignNamenrel.Fields.Append nrel.CreateField(strFName)
nrel.Fields(strFName).ForeignName = strFFName
Next
cdb.Relations.Append nrel
End With
Next
Set fld = Nothing
Set cdb = Nothing
Set td = Nothing
Set cntContainer = Nothing
db.Close
Set db = Nothing
ImportaTodasTabelas = True
End Function
Public Function TableExists(TableName As String) As Boolean
Dim strTableNameCheck
On Error GoTo ErrorCode
strTableNameCheck = CurrentDb.TableDefs(TableName)
TableExists = True
ExitCode:
On Error Resume Next
Exit Function
ErrorCode:
Select Case Err.Number
Case 3265
TableExists = False
Resume ExitCode
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "hlfUtils.TableExists"
Resume ExitCode
End Select
End Function