Pessoal, bom dia!
Tenho um sistema de vendas de vouchers que gera no final do dia 04 arquivos de dados referente ao dia de vendas, estes arquivos são salvos dentro de um diretório chamado BACKUP dentro de um Pendrive, veja os arquivos:
WinCarimb29-04-2008.old
WinImpRenda29-04-2008.old
WinInss29-04-2008.old
WinComissao29-04-2008.old
Bem, estes arquivos são na realidade uma planilha excel, a data na frente do arquivo refere-se ao dia de vendas, todo arquivo gerado sairá com a data atual que for gerado.
Na minha central pego este pendrive e plugo no micro, criando a unidade E:
Tenho um outro sistema que faz a importação destes dados para o Access.
Porém esta importação esta sendo através de macro.
Queria uma rotina que não utilizasse macro.
Vejam minha rotina:
Dim CpnInfo As Database
Dim Voucher As Recordset ' Recordset do tipo Snapshot
Dim ImpRenda As Recordset ' Recordset do tipo Snapshot
Dim Inss As Recordset ' Recordset do tipo Snapshot
Dim Comissao As Recordset
Private Sub cmdAtualizar_Click()
On Error GoTo errado
cmdAtualizar.Enabled = False
cmdFechar.Enabled = False
Pasta_Destino.Path = "E:Backup"
Dim Resp As Byte
Resp = MsgBox("Confirma a Importação dos Dados", vbYesNo + vbQuestion, Me.Caption)
If Resp = 7 Then
cmdAtualizar.Enabled = True
cmdFechar.Enabled = True
Exit Sub
Else
cmdAtualizar.Enabled = False
cmdFechar.Enabled = False
End If
WinCarimb 'Função que renomeia o arquivo para xls
WinImpRenda 'Função que renomeia o arquivo para xls
WinInss 'Função que renomeia o arquivo para xls
WinComissao 'Função que renomeia o arquivo para xls
'-----------Importando---------------------------
Label8.Visible = True
Label8.Caption = "Aguarde, efetuando Importação dos dados..."
Label8.Refresh
MousePointer = vbHourglass ' Muda o ponteiro do mouse
Dim ac As Access.Application
Set ac = New Access.Application
'Indica o caminho do Banco de Dados e faz a conexao com as tabelas
Caminho = ReadINI("Caminho", "BD", App.Path & "Config.ini")
ac.OpenCurrentDatabase (Caminho)
ac.Visible = False
ac.DoCmd.RunMacro "Importador" 'Macro que faz a importação para o BD
MousePointer = vbDefault ' Restaura o ponteiro do mouse.
'Após a importação os arquivos xls serão deletados ficando apenas os arquivos.old
'Detalhe desta importação, os arquivos xls tem os mesmos nomes da tabela do BD e os mesmos campos
Kill ("E:BackupTblVoucherCarimbado.xls")
Kill ("E:BackupTblCadastroImpRenda.xls")
Kill ("E:BackupTblCadastroInss.xls")
Kill ("E:BackupTblCadastroComissao.xls")
'-----------Final do Backup-------------------
cmdAtualizar.Enabled = False
cmdFechar.Enabled = True
Label8.Visible = False
Label8.Refresh
MsgBox "Exportação concluida com sucesso!", vbInformation, Me.Caption
cmdFechar_Click
Exit Sub
errado:
Dim Numero_erro As String
Numero_erro = CStr(Err.Number)
If Numero_erro = "76" Or "68" Then
Call MsgBox("Não Foi Possível localizar o Diretório de Backup." _
& vbCrLf & "Possívelmente o Pen-Drive não foi Inserido, ou" _
& vbCrLf & "o Diretório de Backup no Pen-Drive não foi Criado!" _
& vbNewLine & "Para saber mais consulte o Suporte." _
, vbCritical + vbDefaultButton1, "Erro de Diretório")
cmdFechar_Click
Else
MsgBox ("Error # " & CStr(Err.Number) & " " & Err.Description)
Err.Clear
End If
End Sub Private Sub cmdFechar_Click()
Unload Me
End Sub 'Funçoes para renomear os arquivos old para xls
Function WinCarimb()
Dim Diretorio As String
Diretorio = Format(Date - 1, "DD-MM-YYYY") 'DATA DO DIA ANTERIOR
Diretorio = "E:BackupWinCarimb" & Diretorio & ".old"
If Dir$(Diretorio) <> "" Then
FileCopy (Diretorio), ("E:BackupTblVoucherCarimbado.xls")
Else
MsgBox "Arquivo não encontrado!", vbCritical, "Mensagem"
End If
End Function Function WinImpRenda()
Dim ImpRenda As String
ImpRenda = Format(Date - 1, "DD-MM-YYYY") 'DATA DO DIA ANTERIOR
ImpRenda = "E:BackupWinImpRenda" & ImpRenda & ".old"
If Dir$(ImpRenda) <> "" Then
FileCopy (ImpRenda), ("E:BackupTblCadastroImpRenda.xls")
Else
MsgBox "Arquivo não encontrado!", vbCritical, "Mensagem"
End If
End Function Function WinInss()
Dim Inss As String
Inss = Format(Date - 1, "DD-MM-YYYY") 'DATA DO DIA ANTERIOR
Inss = "E:BackupWinInss" & Inss & ".old"
If Dir$(Inss) <> "" Then
FileCopy (Inss), ("E:BackupTblCadastroInss.xls")
Else
MsgBox "Arquivo não encontrado!", vbCritical, "Mensagem"
End If
End Function Function WinComissao()
Dim Comissao As String
Comissao = Format(Date - 1, "DD-MM-YYYY") 'DATA DO DIA ANTERIOR
Comissao = "E:BackupWinComissao" & Comissao & ".old"
If Dir$(Comissao) <> "" Then
FileCopy (Comissao), ("E:BackupTblCadastroComissao.xls")
Else
MsgBox "Arquivo não encontrado!", vbCritical, "Mensagem"
End If
End Function Obs:
Quero uma rotina no lugar do macro, porque o macro sempre dá pau e não faz a importação com precisão.
Alguém pode me ajudar.
Marcelino Neto