Olá, recentimente precisei exportar para um outro banco, criado em run-time todo o conteudo de um RS, para especie de backup, e achei uma dica ali, aculá....e misturei as e deu no que eu queria veja se ajuda:
cria um module....
Option Explicit
Global BD As New ADODB.Connection 'VAR PARA O BD NOVO
Global TB As New ADODB.Recordset
'IMPORTANTE
'1º - CRIA O BANCO DE DADOS
'2º - CRIA A TABELA
'3º - CONECTA PARA EXPORTAR
Public Banco, NomeDaTabela As String
Public TBL As ADOX.Table
Public CAT As ADOX.Catalog
Public Sub CreateMDB()
'On Error GoTo ErrTrap
10 On Error GoTo CreateMDB_Error
20 Banco = "NF_" & TbCad!Razao_Social & "_" & Mes & "_" & Ano & "_" & ".MDB"
'Senha = "123456"
30 NomeDaTabela = "TabNotas"
40 If Dir(App.Path & "" & Banco) <> Empty Then
50 Kill App.Path & "" & Banco
60 End If
70 Set CAT = New ADOX.Catalog
' ===[Create Database]===
80 CAT.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & App.Path & "" & Banco & _
";Jet OLEDB:Database Password=" & Senha & _
";Jet OLEDB:Engine Type=5;"
' ===cria a tabela========
90 CreateTables
'=====CONECT O BANCO CRIADO ==============
100 ConexaoExporta
'=====exporta os dados ============
110 ExportaDados
'MsgBox "Banco de dados criado com sucesso em " & vbCrLf & _
"[ " & Banco & " ]", vbInformation, App.Title
120 Exit Sub
ErrTrap:
130 MsgBox Err.Number & " - " & Err.Description
140 Exit Sub
150 Resume
160 On Error GoTo 0
170 Exit Sub
CreateMDB_Error:
180 MsgBox "Erro Interno de número " & Err.Number & " - " & Err.Description & " - linha " & Erl & " na procedure CreateMDB no Módulo CreateBD", vbCritical, "CreateBD"
End Sub
Private Sub CreateTables()
'Dim TBL As ADOX.Table ==> como public para poder SET
' ===[Create Table 'TabNotas']===
10 On Error GoTo CreateTables_Error
20 Set TBL = New ADOX.Table
30 Set TBL.ParentCatalog = CAT
40 TBL.Name = NomeDaTabela
50 TBL.Columns.Append "ID", adInteger, 0
60 TBL.Columns("ID").Properties("NullAble") = True
70 TBL.Columns.Append "TIPO", adVarWChar, 20
80 TBL.Columns("TIPO").Properties("NullAble") = True
90 TBL.Columns.Append "ESPECIE", adVarWChar, 20
100 TBL.Columns("ESPECIE").Properties("NullAble") = True
110 TBL.Columns.Append "DIA", adInteger, 0
120 TBL.Columns("DIA").Properties("NullAble") = True
130 TBL.Columns.Append "MES", adInteger, 0
140 TBL.Columns("MES").Properties("NullAble") = True
150 TBL.Columns.Append "ANO", adInteger, 0
160 TBL.Columns("ANO").Properties("NullAble") = True
170 TBL.Columns.Append "DATA", adVarWChar, 50
180 TBL.Columns("DATA").Properties("NullAble") = True
190 TBL.Columns("DATA").Properties("Description") = "'só serve para o campo data do relatório"
200 TBL.Columns.Append "NF", adDouble, 0
210 TBL.Columns("NF").Properties("NullAble") = True
220 TBL.Columns.Append "BASE_CALCULO", adVarWChar, 50
230 TBL.Columns("BASE_CALCULO").Properties("NullAble") = True
240 TBL.Columns.Append "ICMS", adVarWChar, 50
250 TBL.Columns("ICMS").Properties("NullAble") = True
260 TBL.Columns.Append "IPIEmb", adVarWChar, 5
270 TBL.Columns("IPIEmb").Properties("NullAble") = True
280 TBL.Columns("IPIEmb").Properties("Default") = "Não"
290 TBL.Columns.Append "IPI", adVarWChar, 50
300 TBL.Columns("IPI").Properties("NullAble") = True
310 TBL.Columns.Append "OUTRAS", adVarWChar, 50
320 TBL.Columns("OUTRAS").Properties("NullAble") = True
330 TBL.Columns.Append "VALOR_TOTAL", adVarWChar, 50
340 TBL.Columns("VALOR_TOTAL").Properties("NullAble") = True
350 CAT.Tables.Append TBL
360 On Error GoTo 0
370 Exit Sub
CreateTables_Error:
380 MsgBox "Erro Interno de número " & Err.Number & " - " & Err.Description & " - linha " & Erl & " na procedure CreateTables no Módulo CreateBD", vbCritical, "CreateBD"
End Sub
Public Sub ConexaoExporta()
'conecta com o banco de dados e a tabela criados
10 On Error GoTo ConexaoExporta_Error
20 BD.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & App.Path & "" & Banco & _
";Jet OLEDB:Database Password=" & Senha
30 TB.CursorLocation = adUseClient
40 TB.Open "SELECT * FROM " & NomeDaTabela, BD, adOpenDynamic, adLockOptimistic
50 On Error GoTo 0
60 Exit Sub
ConexaoExporta_Error:
70 MsgBox "Erro Interno de número " & Err.Number & " - " & Err.Description & " - linha " & Erl & " na procedure ConexaoExporta no Módulo CreateBD", vbCritical, "CreateBD"
End Sub
Public Sub ExportaDados()
Dim SQL3 As String, I As Integer
10 On Error GoTo ExportaDados_Error
20 For I = 1 To TbNot.RecordCount
30 SQL3 = "INSERT INTO " & NomeDaTabela & "("
40 SQL3 = SQL3 & "ID, "
50 SQL3 = SQL3 & "TIPO, "
60 SQL3 = SQL3 & "ESPECIE, "
70 SQL3 = SQL3 & "DIA, "
80 SQL3 = SQL3 & "MES, "
90 SQL3 = SQL3 & "ANO, "
100 SQL3 = SQL3 & "DATA, "
110 SQL3 = SQL3 & "NF, "
120 SQL3 = SQL3 & "BASE_CALCULO, "
130 SQL3 = SQL3 & "ICMS, "
140 SQL3 = SQL3 & "IPI, "
150 SQL3 = SQL3 & "IPIemb, "
160 SQL3 = SQL3 & "OUTRAS, "
170 SQL3 = SQL3 & "VALOR_TOTAL) VALUES ("
180 SQL3 = SQL3 & TbNot!ID & ", "
190 SQL3 = SQL3 & "'" & TbNot!Tipo & "', "
200 SQL3 = SQL3 & "'" & TbNot!especie & "', "
210 SQL3 = SQL3 & TbNot!Dia & ", " 'DIA
220 SQL3 = SQL3 & TbNot!Mes & ", " 'MES
230 SQL3 = SQL3 & TbNot!Ano & ", " 'ANO ****DATA ***********
240 SQL3 = SQL3 & "'" & TbNot!DATA & "', "
250 SQL3 = SQL3 & TbNot!NF & ", "
260 SQL3 = SQL3 & "'" & TbNot!BASE_CALCULO & "', "
270 SQL3 = SQL3 & "'" & TbNot!ICMS & "', "
280 SQL3 = SQL3 & "'" & TbNot!IPI & "', "
290 SQL3 = SQL3 & "'" & TbNot!IPIemb & "', "
300 SQL3 = SQL3 & "'" & TbNot!OUTRAS & "', "
310 SQL3 = SQL3 & "'" & TbNot!VALOR_TOTAL & "')"
320 Set TB = BD.Execute(SQL3)
330 TbNot.MoveNext
340 With FormConfigi
350 DoEvents
360 .LblStatusBackup.Caption = "Gerando arquivo access das NF de " & Mes & "/" & Ano & " - " & I & "/" & TbNot.RecordCount
370 .ProgressoTXT.Value = I
380 End With
390 Next I
400 FormConfigi.LblStatusBackup.Caption = "Arquivo access gerado com sucesso !"
410 TbNot.MoveMin
420 BD.Close
430 Set BD = Nothing
440 Set CAT = Nothing
450 Set TBL = Nothing
460 On Error GoTo 0
470 Exit Sub
ExportaDados_Error:
480 MsgBox "Erro Interno de número " & Err.Number & " - " & Err.Description & " - linha " & Erl & " na procedure ExportaDados no Módulo CreateBD", vbCritical, "CreateBD"
End Sub
