MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

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

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

    Compartilhe

    wbonelli
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 62
    Registrado : 02/04/2011

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

    Mensagem  wbonelli em Seg 14 Abr 2014, 16:33

    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

    wbonelli
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 62
    Registrado : 02/04/2011

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

    Mensagem  wbonelli em Ter 15 Abr 2014, 11:40

    Bom dia Pessoal,

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

    wbonelli
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 62
    Registrado : 02/04/2011

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

    Mensagem  wbonelli em Qua 16 Abr 2014, 18:29

    Desculpem a insistência, mas estou precisando mesmo.

    Já tentei adaptar outras rotinas, como esta:

    No site JR Access Faq: [Você precisa estar registrado e conectado para ver este link.]

    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]

    wbonelli
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 62
    Registrado : 02/04/2011

    Pessoal, será que tem como me ajudar?

    Mensagem  wbonelli em Ter 29 Abr 2014, 18:49

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

      Data/hora atual: Qui 20 Jul 2017, 15:25