esse eu importo arquivo da caixa
Public Function ImportaOFX(Caminho As String, cConta As Integer)
Dim DB As Database
Dim RS, r As Recordset
Dim CodOFx As Integer
Dim Sec As Variant
Dim Rotulo, Linha As String
Set DB = CurrentDb
'Abrir arquivo, adicionar novo extrato na tabela OFX
'---------------------------------------------------
nFileNum = FreeFile
Open Caminho For Input As nFileNum
'Form_OFXimport.pbar.Value = 2
'Abrir tabela OFX e adicionar novo extrato
Set r = DB.OpenRecordset("OFX", dbOpenDynaset)
r.AddNew
r!NomeExtrato = "EXT-" & cConta & Format(Time, "HHssmm")
r!data = Format(Date, "dd/mm/yyyy", vbUseSystemDayOfWeek, vbUseSystem)
r!Conta = cConta
'Percorre linha por linha do arquivo
Do Until EOF(nFileNum)
Line Input #nFileNum, slinetext
If slinetext = "" Then 'se a linha é vazia, vai pra próxima!
GoTo pulalinha
End If
Linha = LTrim(Replace(slinetext, vbTab, " ")) 'Substitui as tabulações por espaços e corta os espaços
Sec = Split(Linha, ">", 2, vbTextCompare) 'Secciona a linha até o caracter >
Rotulo = Sec(0) 'pega a primeira parte da seção
Select Case Rotulo
Case Is = "
r!IdBanco = Mid(Linha, 19)
Case Is = "
r!IdConta = Mid(Linha, 19)
Case Is = "
r!dti = DateSerial(Int(Mid(Linha, 10, 4)), Int(Mid(Linha, 14, 2)), Int(Mid(Linha, 16, 2)))
Case Is = "
r!Dtf = DateSerial(Int(Mid(Linha, 8, 4)), Int(Mid(Linha, 12, 2)), Int(Mid(Linha, 14, 2)))
End Select
pulalinha:
'Form_OFXimport.pbar.Value = Form_OFXimport.pbar.Value + 0.1
Loop
r.Update
r.MoveLast
CodOFx = r!COD 'pega o código do extrato salvo para vincular os movimentos
r.Close
Close nFileNum
Set r = Nothing
'Agora lançar os movimentos
'-------------------------------------------------------------------------
Open Caminho For Input As nFileNum 'abre o mesmo arquivo
'Form_OFXimport.pbar.Value = 50
Set RS = DB.OpenRecordset("SubOFX", dbOpenDynaset) 'abre a tabela para receber os dados
Do Until EOF(nFileNum)
Line Input #nFileNum, slinetext
If slinetext = "" Then 'se a linha é vazia, pula ela!
GoTo passadireto
End If
Linha = LTrim(Replace(slinetext, vbTab, " ")) 'substitui as tabulações por espaços e corta os espaços
Sec = Split(Linha, ">", 2, vbTextCompare) 'secciona a linha (>)
Rotulo = Sec(0) 'pega a primeira parte da seção
Select Case Rotulo
Case Is = "
RS.AddNew
Case Is = "
'define o tipo = 1 ou 2 e armazena
If Mid(Linha, 10, 5) = "DEBIT" Then
RS!tipo = 2
Else
RS!tipo = 1
End If
Case Is = "
'armazena a data
RS!data = DateSerial(Int(Mid(Linha, 11, 4)), Int(Mid(Linha, 15, 2)), Int(Mid(Linha, 17, 2)))
Case Is = "
'armazena o valor
If RS!tipo = 1 Then
RS!Valor = FormatCurrency(Mid(Linha, 9), 2, vbUseDefault, vbUseDefault, vbUseDefault) / 100
RS!Credito = FormatCurrency(Mid(Linha, 9), 2, vbUseDefault, vbUseDefault, vbUseDefault) / 100
Else
RS!Valor = FormatCurrency(Mid(Linha, 10), 2, vbUseDefault, vbTrue, vbUseDefault) / 100
RS!Debito = FormatCurrency(Mid(Linha, 10), 2, vbUseDefault, vbTrue, vbUseDefault) / 100
End If
Case Is = "
'armazena o cheque
RS!Doc = Mid(Linha, 11)
Case Is = "
'armazena o memorando
RS!Memorando = Mid(Linha, 7)
Case Is = " 'armazena o CODOFX
RS!OFX = CodOFx
RS.Update
Case Is = " RS.Close
'sai da função
End Select
passadireto:
'Form_OFXimport.pbar.Value = Form_OFXimport.pbar.Value + 0.1
Loop
Close nFileNum
'Form_OFXimport.pbar.Value = 100
MsgBox "OFX importado com sucesso!", vbInformation, "Mensagem"
'Form_OFXimport.pbar.Value = 0.0001
Set DB = Nothing
Set RS = Nothing
End Function