MaximoAccess

Caro Usuário, não tire as suas duvidas nas Salas de Repositório, abra sempre um novo tópico relacionado, nas salas destinadas para o efeito, como Sala de Tabelas, Consultas, Formulários, Relatórios, Macros, Módulos e VBA.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

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

    Compartilhe

    lebersa12
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 108
    Registrado : 16/05/2014

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

    Mensagem  lebersa12 em Seg 10 Nov 2014, 12:49

    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.

    [Você precisa estar registrado e conectado para ver este link.]
    Anexos
    Fórum.zip
    Você não tem permissão para fazer download dos arquivos anexados.
    (56 Kb) Baixado 8 vez(es)

    Alexandre Neves
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 5889
    Registrado : 05/11/2009

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

    Mensagem  Alexandre Neves em Seg 10 Nov 2014, 13:55

    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


    .................................................................................
    Access 2010. Mande bd que dê para testar (indique a versão). Não peça para fazer o que já tem feito. Dê todos os detalhes.
    Não coloquem entraves como senhas, esconder controlos, etc. Disponibilizem o mais limpo possível
    Só respondo a mensagens privadas, se forem de assunto privado; às outras não respondo.
    Quem trabalha e mata a fome não come o pão de ninguém; mas quem não trabalha e come, come sempre o pão de alguém. António Aleixo

    lebersa12
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 108
    Registrado : 16/05/2014

    Identificar arquivos no diretório e Executar uma rotina.

    Mensagem  lebersa12 em Seg 10 Nov 2014, 17:13

    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

    Alexandre Neves
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 5889
    Registrado : 05/11/2009

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

    Mensagem  Alexandre Neves em Ter 11 Nov 2014, 14:01

    Boa tarde,
    fso1.DeleteFile (fl.path)


    .................................................................................
    Access 2010. Mande bd que dê para testar (indique a versão). Não peça para fazer o que já tem feito. Dê todos os detalhes.
    Não coloquem entraves como senhas, esconder controlos, etc. Disponibilizem o mais limpo possível
    Só respondo a mensagens privadas, se forem de assunto privado; às outras não respondo.
    Quem trabalha e mata a fome não come o pão de ninguém; mas quem não trabalha e come, come sempre o pão de alguém. António Aleixo

    lebersa12
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 108
    Registrado : 16/05/2014

    Identificar arquivos no diretório e Executar uma rotina.

    Mensagem  lebersa12 em Ter 11 Nov 2014, 15:08

    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.

    Alexandre Neves
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 5889
    Registrado : 05/11/2009

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

    Mensagem  Alexandre Neves em Ter 11 Nov 2014, 15:48

    Depois de ler o arquivo, feche-o
    Close ArquivoTexto


    .................................................................................
    Access 2010. Mande bd que dê para testar (indique a versão). Não peça para fazer o que já tem feito. Dê todos os detalhes.
    Não coloquem entraves como senhas, esconder controlos, etc. Disponibilizem o mais limpo possível
    Só respondo a mensagens privadas, se forem de assunto privado; às outras não respondo.
    Quem trabalha e mata a fome não come o pão de ninguém; mas quem não trabalha e come, come sempre o pão de alguém. António Aleixo

    lebersa12
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 108
    Registrado : 16/05/2014

    Identificar arquivos no diretório e Executar uma rotina.

    Mensagem  lebersa12 em Ter 11 Nov 2014, 17:13

    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.

      Data/hora atual: Sex 09 Dez 2016, 09:36