Public Function CreateEmptyDatabase(ByVal DbName As String) As Database
On Error Resume Next
Dim db As Database
If Dir(DbName) <> "" Then
'existe
Set db = OpenDatabase(DbName)
Else
'nao existe, tem que cria-lo
Set db = CreateDatabase(DbName, dbLangGeneral)
End If
Set CreateEmptyDatabase = db
End Function
'***********************************************************************************************
'=======================================================================
' Rotina para copia de estrutura de tabela, compativel com VB3/4/5/6 e
' VBA, usando DAO.
' (e-mail address removed)
'=======================================================================
Function CopyStruct(from_db As Database, _
to_db As Database, _
from_nm As String, _
to_nm As String, _
create_ind As Integer) As Integer
On Error GoTo Erro
Const gstDataType = ""
Dim i As Integer
Dim tbl As New TableDef 'objeto de tabela
Dim fld As Field 'objeto de campo
Dim ind As index 'objeto de indice
Dim iCrash As Integer
Dim szBkto_nm As String
'mecanismos de protecao/colisao de nomes
szBkto_nm = to_nm
iCrash = 1
'verifica se a tabela ja existe
BuscaNome:
For i = 0 To to_db.TableDefs.Count - 1
If UCase(to_db.TableDefs(i).Name) = UCase(to_nm) Then
If MsgBox(to_nm + " já existe, quer apaga-la?", 4) = vbYes
Then
to_db.TableDefs.Delete to_nm
Else
'cria um novo nome sequencial
to_nm = "Copia " & Format(iCrash, "0000") & " de " &
szBkto_nm
iCrash = iCrash + 1
GoTo BuscaNome
End If
Exit For
End If
Next
'Retira dados do proprietario, se houver necessidade
If InStr(to_nm, ".") <> 0 Then
to_nm = Mid(to_nm, InStr(to_nm, ".") + 1, Len(to_nm))
End If
tbl.Name = to_nm
'cria todos os campos
For i = 0 To from_db.TableDefs(from_nm).Fields.Count - 1
Set fld = New Field
fld.Name = from_db.TableDefs(from_nm).Fields(i).Name
fld.Type = from_db.TableDefs(from_nm).Fields(i).Type
fld.Size = from_db.TableDefs(from_nm).Fields(i).Size
fld.Attributes =
from_db.TableDefs(from_nm).Fields(i).Attributes
tbl.Fields.Append fld
Next
'Cria todos os indices, se assim foi designado
If create_ind <> False Then
For i = 0 To from_db.TableDefs(from_nm).Indexes.Count - 1
Set ind = New index
ind.Name = from_db.TableDefs(from_nm).Indexes(i).Name
ind.Fields = from_db.TableDefs(from_nm).Indexes(i).Fields
ind.Unique = from_db.TableDefs(from_nm).Indexes(i).Unique
If gstDataType <> "ODBC" Then
ind.Primary = from_db.TableDefs(from_nm).Indexes(i).Primary
End If
tbl.Indexes.Append ind
Next
End If
'salva nova tabela na colecao
to_db.TableDefs.Append tbl
CopyStruct = True
GoTo Fim
Erro:
CopyStruct = False
Resume Fim
Fim:
End Function
'=======================================================================
' Rotina para copia de dados entre tabelas (DAO), compativel com
VB3/4/5/6
' VBA
' (e-mail address removed)
'
' NAO COPIA TABELAS QUE NAO SEJAM EXATAMENTE IGUAIS, INCLUINDO ORDEM
DOS
' CAMPOS NA TABELA. INDICADA PARA USO COM CopyStruct()
'=======================================================================
Function CopyData(from_db As Database, _
to_db As Database, _
from_nm As String, _
to_nm As String) As Integer
On Error GoTo Erro
'Dim ds1 As Dynaset, ds2 As Dynaset
Dim ds1 As DAO.Recordset, ds2 As DAO.Recordset
Dim i As Integer
'obtem referencia das tabelas
Set ds1 = from_db.OpenRecordset(from_nm)
Set ds2 = to_db.OpenRecordset(to_nm)
'copia ate o final do arquivo
While ds1.EOF = False
'novo registro
ds2.AddNew
'todos os campos
For i = 0 To ds1.Fields.Count - 1
'atribui valor ao campo da nova tabela
ds2(i) = ds1(i)
Next
'salva
ds2.Update
'proximo registro
ds1.MoveNext
Wend
'concluido com exito
CopyData = True
GoTo Fim
Erro:
CopyData = False
Resume Fim
Fim:
End Function
