[Resolvido]Identificar arquivos no diretório e Executar uma rotina

Bom dia!

Deixei anexo, o código que utilizo para importar arquivos txt e Excel e a estrutura exata dos arquivos que obedecem um determinado padrão e critérios. Esse código funciona perfeitamente, quando o usuário clica no botão um determinado diretório é aberto  permitindo ao usuário escolher o arquivo que deseja importar em seguida clica duas vezes e a rotina é executada. Caso possua 100 arquivos, o usuário terá que clicar nos 100 arquivos, sendo que 1 por vez para obter as informações.

A minha dúvida...

É possível, que ao clicar no botão, a rotina de importação seja executada nos arquivos que estiverem no diretorio e em seguida apagá-los? Importante informar que cada arquivo deve ser importado individualmente por conter informações distintas.

Aos amigos que forem me auxiliar, antes de postar a dúvida, pesquisei nos tópicos que falam sobre Diretório e o mais próximo que encontrei foi o do Mestre JPaulo, porém não tive êxito em adaptar em meu projeto.

http://maximoaccess.forumeiros.com/t14255-resolvidoler-diretorios

Boa tarde,
Function ImportarExcel()
Dim fso As FileSystemObject
Dim F As file, Pasta
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean
blnHasFieldNames = True
strTable = "TInputNFTemp"

Set fso = New FileSystemObject

Set Pasta = fso.GetFolder("NomePasta")
For Each F In Pasta.Files
strPathFile = NomePasta & F.Name

DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTable, strPathFile, True, "InputNF" & "!A11:I5000"
'Comando que obedece um layout fixo de arquivo, caso o lay out seja alterado, é importante modificar o intervalo do Range


CurrentDb.Execute "CInputNF1"
CurrentDb.Execute "CClInputNF"

MsgBox "O Arquivo Cessão Elavon foi importado com sucesso"
next

For Each F In Pasta.Files
F.delete
next

'******************************************************
'Importante!!!
'O transporte dos dados é feita para a tabela temporária TInputNFTemp, após isso, eu faço uma consulta para acrescentar os dados para a tabela TInputNF
'*******************************************************

End Function

Prezado Alexandre,

Muito obrigado por sua ajuda...

O código na importação dos arquivos Excel funcionou perfeitamente.
Na rotina de importação de arquivos de texto está ocorrendo um erro na linha onde há o comando para deletar o arquivo que foi importado.

Erro:

Erro em tempo de execução '70'
Permissão negada

Código:

Function ImportaTxt()

Dim fso1 As FileSystemObject
Dim f1 As file, Pasta1
Dim strPathFile1 As String, strFile1 As String, strPath1 As String
Dim blnHasFieldNames1 As Boolean
blnHasFieldNames1 = True

Set fso1 = New FileSystemObject

Set Pasta1 = fso1.GetFolder(CurrentProject.Path & "\Arquivos Texto")
For Each f1 In Pasta1.Files
strPathFile1 = CurrentProject.Path & "\Arquivos Texto" & "\" & f1.Name


Dim rs As DAO.Recordset
Dim fnum As Integer
Dim LinhaDoTexto As String
Dim ArquivoTexto As String
Dim nCount As Long
Dim nLinha As Integer
Dim strSQL As String
Dim CaminhoCopia As String
Dim ContaLinha As Long


Dim DATA_TRANSACAO As Variant
Dim DATA_LIQ_FIN As Variant

Dim BRADESCO11102 As Variant
Dim BRADESCO11603 As Variant
Dim BRADESCO4380 As Variant
Dim BRADESCO6175 As Variant

Dim BRADESCARD5144 As Variant
'Dim BRADESCARD13757 As Variant
Dim BRADESCARD14075 As Variant

Dim BB4348 As Variant
Dim BB6145 As Variant
Dim BB13454 As Variant
Dim BB13804 As Variant

Dim SANTANDER8328 As Variant
Dim SANTANDER11783 As Variant

Dim CEF4476 As Variant
Dim CEF6492 As Variant

Dim ITAUBB4373 As Variant
Dim ITAUBB6282 As Variant
Dim ITAUBB9970 As Variant
Dim ITAUBB9992 As Variant
Dim ITAUBB12848 As Variant
Dim ITAUBB13755 As Variant

strSQL = "SELECT * FROM TMastercard"

Set rs = CurrentDb.OpenRecordset(strSQL)

ArquivoTexto = f1

fnum = FreeFile

Open ArquivoTexto For Input As fnum

    Do While Not EOF(fnum)
        nLinha = nLinha + 1
        Line Input #fnum, LinhaDoTexto
       
        If InStr(LinhaDoTexto, "SETTLEMENT DATE:") > 0 Then
          DATA_TRANSACAO = fncModificaData(LTrim(RTrim(Mid(LinhaDoTexto, 29, 11))))
       
        End If
       
            If InStr(LinhaDoTexto, "VALUE DATE:") > 0 Then
                DATA_LIQ_FIN = fncModificaData(LTrim(RTrim(Mid(LinhaDoTexto, 29, 11))))
            End If
       
'==============================================================================
'                          **********        BRADESCO
'==============================================================================
       
 Dim B1, B2, B3, B4 As Integer

       
            If InStr(LinhaDoTexto, 11102) > 0 Then
                B1 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = B1 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BRADESCO11102 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
           
            If InStr(LinhaDoTexto, 11603) > 0 Then
                B2 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = B2 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BRADESCO11603 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
           
            If InStr(LinhaDoTexto, 4380) > 0 Then
                B3 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = B3 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BRADESCO4380 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            If InStr(LinhaDoTexto, 6175) > 0 Then
                B4 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = B4 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BRADESCO6175 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
           
'==============================================================================
'                          **********        Itaú Unibanco
'==============================================================================

Dim I1, I2, I3, I4, I5, I6 As Variant


            If InStr(LinhaDoTexto, 4373) > 0 Then
                I1 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = I1 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                ITAUBB4373 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            If InStr(LinhaDoTexto, 6282) > 0 Then
                I2 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = I2 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                ITAUBB6282 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               

            If InStr(LinhaDoTexto, 9970) > 0 Then
                I3 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = I3 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                ITAUBB9970 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            If InStr(LinhaDoTexto, 9992) > 0 Then
                I4 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = I4 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                ITAUBB9992 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
     
            If InStr(LinhaDoTexto, 12848) > 0 Then
                I5 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = I5 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                ITAUBB12848 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If

            If InStr(LinhaDoTexto, 13755) > 0 Then
                I6 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = I6 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                ITAUBB13755 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
'==============================================================================
'                          **********        BANCO DO BRASIL, S.A
'==============================================================================

Dim BB1, BB2, BB3, BB4 As Variant

            If InStr(LinhaDoTexto, 4348) > 0 Then
                BB1 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BB1 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BB4348 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            If InStr(LinhaDoTexto, 6145) > 0 Then
                BB2 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BB2 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BB6145 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            If InStr(LinhaDoTexto, 13454) > 0 Then
                BB3 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BB3 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BB13454 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            If InStr(LinhaDoTexto, 13804) > 0 Then
                BB4 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BB4 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BB13804 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
               
'==============================================================================
'                          **********        BANCO BRADESCARD S.A
'==============================================================================
               
  Dim BR1, BR2, BR3 As Variant
               
            If InStr(LinhaDoTexto, 5144) > 0 Then
                BR1 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BR1 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BRADESCARD5144 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            'If InStr(LinhaDoTexto, 13757) > 0 Then
            '    BR2 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            'End If
            '    If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BR2 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
            '    BRADESCARD13757 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
            '    End If
               
            If InStr(LinhaDoTexto, 14075) > 0 Then
                BR3 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BR3 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                BRADESCARD14075 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
'==============================================================================
'                          **********        CAIXA ECONOMICA FEDE
'==============================================================================
               
  Dim CEF1, CEF2 As Variant
               
            If InStr(LinhaDoTexto, 4476) > 0 Then
                CEF1 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = CEF1 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                CEF4476 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            If InStr(LinhaDoTexto, 6492) > 0 Then
                CEF2 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = CEF2 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                CEF6492 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
'==============================================================================
'                          **********        BANCO SANTANDER (BRA
'==============================================================================
               
  Dim BS1, BS2 As Variant
               
            If InStr(LinhaDoTexto, 8328) > 0 Then
                BS1 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BS1 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                SANTANDER8328 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If
               
            If InStr(LinhaDoTexto, 11783) > 0 Then
                BS2 = LTrim(RTrim(Mid(LinhaDoTexto, 4, 2)))
            End If
                If LTrim(RTrim(Mid(LinhaDoTexto, 4, 2))) = BS2 And InStr(LinhaDoTexto, "BRA") > 0 And InStr(LinhaDoTexto, "C") > 0 Then
                SANTANDER11783 = LTrim(RTrim(Mid(LinhaDoTexto, 22, 16)))
                End If

    Loop
   

    rs.AddNew
   
    rs(1) = DATA_TRANSACAO
    rs(2) = DATA_LIQ_FIN
    rs(3) = BRADESCO11102
    rs(4) = BRADESCO11603
    rs(5) = BRADESCO4380
    rs(6) = BRADESCO6175
   
    rs(7) = BRADESCARD5144
    'rs(8) = BRADESCARD13757
    rs(9) = BRADESCARD14075
   
    rs(10) = BB4348
    rs(11) = BB6145
    rs(12) = BB13454
    rs(13) = BB13804
   
    rs(14) = SANTANDER8328
    rs(15) = SANTANDER11783
   
    rs(16) = CEF4476
    rs(17) = CEF6492
   
    rs(18) = ITAUBB4373
    rs(19) = ITAUBB6282
    rs(20) = ITAUBB9970
    rs(21) = ITAUBB9992
    rs(22) = ITAUBB12848
    rs(23) = ITAUBB13755
       
           
    rs.Update
    Call ExecutarBancos
   
    'Envia a soma dos bancos para a tabela TBancosValidos

   
MsgBox "Dados importados com sucesso.!"

Next

For Each f1 In Pasta1.Files
f1.Delete '####AQUI ACONTECE O ERRO
Next



End Function

Boa tarde,
fso1.DeleteFile (fl.path)

Boa tarde Alexandre,

Infelizmente está retornando o mesmo erro.

Antes de sua resposta, tentei inserir o comando Kill nos arquivos da pasta, mas o erro que dá é a informação que o arquivo está em uso.

Depois de ler o arquivo, feche-o
Close ArquivoTexto

Alexandre,

Muito obrigado mesmo. Mais uma que vc me ajuda!!!

Somente referente a sua mensagem anterior, a linha de alteração ficou assim...

Close fnum

Todo o restante funcionou perfeitamente.