Importação de arquivos remessa Bradesco para Tabela - MODIFICADO

Boa Noite Pessoal!

Estou necessitando muito da ajuda de vocês com uma rotina de importação de Arquivo Retorno.
Ela funciona direitinho, até porque não foi eu quem a fez, apenas adaptei às minhas necessidades.
Agora estou tentando melhorá-la para que faça a importação de vários arquivos ao mesmo tempo, de uma pasta expecífica.
O caminho da pasta é obtido de um campo txtPath. e os arquivos tem a terminação .ret
Já fiz uns testes com a modificação abaixo e funciona apenas no primeiro arquivo. Entretanto aparece no 'Debug.Print "importing " & strFile' que todos os arquivos da pasta foram tratados.

Agradeço muito caso possam me ajudar.
Abaixo segue a rotina:

Dim db As Database
Dim rs As Recordset
Dim Linha As String
On Error Resume Next
Dim strDir As String
Dim strFile As String
Dim I As Long

'DoCmd.OpenQuery "Qry_Limpa_Tabela_BoletosImportadosPagos" 'apaga registros anteriores
Set db = CurrentDb
Set rs = db.OpenRecordset("Boletos_Pagos_importar_access", dbOpenTable)

I = 0

If Left(txtPath, 1) <> "\" Then
strDir = txtPath & "\"
Else
strDir = txtPath
End If
strFile = Dir(strDir & "*.ret")

Do While strFile <> ""
I = I + 1

strFile = strDir & strFile
Debug.Print "importing " & strFile

Open strFile For Input As #1 ' Abre o arquivo a ser importado
While Not EOF(1)

Line Input #1, Linha ' Lê uma linha do arquivo texto
If Left$(Linha, 1) = "1" Then
With rs
.AddNew

!conta = Mid$(Linha, 21, 17)
!Nosso_Numero = Mid$(Linha, 71, 11)
!Documento = Mid$(Linha, 117, 10)
!Operacao = Mid$(Linha, 109, 2)
!valor = Mid$(Linha, 153, 13) / 100
!emissao = Mid$(Linha, 296, 2) & "/" & _
Mid$(Linha, 298, 2) & "/" & _
Mid$(Linha, 300, 2)
!valor = Mid$(Linha, 254, 13) / 100
!juros = Mid$(Linha, 267, 13) / 100
!Data_Pag = Mid$(Linha, 111, 2) & "/" & _
Mid$(Linha, 113, 2) & "/" & _
Mid$(Linha, 115, 2)
!CNPJ = Mid$(Linha, 4, 14)
!Sacado = Mid$(Linha, 38, 14)

.Update
End With

End If

Wend

strFile = Dir()
Loop

Saida:
Close
Set rs = Nothing
Set db = Nothing

MsgBox "Arquivo Importado com Sucesso, clique em atualizar para Processar os dados"

Exit Sub

TrataErro:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Erro: " & CStr(Err.Number)
#If DESENV Then ' Compilação condicional - Em desenvolvimento
Stop
Resume
#End If
Resume Saida

wbonelli

Bom dia Pessoal,

Por favor, alguém tem idéia em que estou errando? Obrigado.

Desculpem a insistência, mas estou precisando mesmo.

Já tentei adaptar outras rotinas, como esta:

No site JR Access Faq: http://www.accessfaq.com.br/

Código:

Attribute VB_Name = "basExemplos"
Option Compare Database
Option Explicit

'Rotinas de Exemplo:

' ImportaTexto()

Sub ImportaTexto(Tabela As String)

' Rotina para automatizar a importação de diversos arquivos _
  TXT (ex.: Data1.txt, Data2.txt até DataN.txt) para uma Tabela, _
  com medidor de Progresso na Barra de Status do Access
  
' Esta rotina foi usada para importar 3515 arquivos _
  textos para a construção deste aplicativo

    On Error GoTo erro_função
    Dim rs As Recordset, strLinha As String, TodoTexto As String
    Dim StatusTexto As String, ContaReg As Integer
 
   ContaReg = 0  'zera o contador de registros.
    Set rs = CurrentDb.OpenRecordset(Tabela)
    Screen.MousePointer = 11  'muda cursor para ampulheta.
    With rs
    'inicia a Barra de Progresso.
    StatusTexto = "Lendo Arquivos ..."
    .MoveLast
    SysCmd acSysCmdInitMeter, StatusTexto, .RecordCount
    .MoveFirst
        Do While Not .EOF
            Open "d:\Forum Access\JR\Dados\Data." & CStr(!Resposta_Id) For Input As #1
            ContaReg = ContaReg + 1
            SysCmd acSysCmdUpdateMeter, ContaReg 'atualiza o progresso.
            DoEvents 'Deve ser usada se nº de arq txt for grande.
            
            ' Lê arq txt linha a linha e salva na Tabela.
            Do Until EOF(1)
                Line Input #1, strLinha
                TodoTexto = TodoTexto & strLinha & vbCrLf
            Loop
            Close #1
            .Edit
            !Resposta = Trim(TodoTexto)
            .Update
            .MoveNext
            strLinha = ""
            TodoTexto = ""
        Loop
    End With
    Screen.MousePointer = 0   'volta o cursor para o normal.
    SysCmd acSysCmdRemoveMeter  'remove a ProgressBar.
    Set rs = Nothing
    MsgBox "Importados " & ContaReg & " textos com sucesso!", vbExclamation, "Fim de Operação"
    Exit Sub
    
erro_função:
    Call InformaErro
    Screen.MousePointer = 0
    Close #1
    
End Sub

sem sucesso. Se deve certamente ao meu pouco conhecimento de VBA.

Se possível, peço ajudar-me.
Obrigado.
Wagner[/b]

Pessoal, será que tem como me ajudar?
Obrigado!