MaximoAccess

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

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

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

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

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

3 participantes

    [Resolvido]Importar Xml Lote "Importar Duplicata"

    avatar
    NADIRONUNES
    Super Avançado
    Super Avançado

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 508
    Registrado : 30/08/2010

    [Resolvido]Importar Xml Lote "Importar Duplicata" Empty [Resolvido]Importar Xml Lote "Importar Duplicata"

    Mensagem  NADIRONUNES 24/2/2017, 16:24

    boa tarde preciso importar as duplicatas e parte do frete da xml usando o codigo do FabioPaes

    Public Function ImportaXML(LocalXml As String)
    '---------------------------------------------------------------'
    ' Criado por FabioPaes '
    ' Em 12/02/2017 para MAXIMOACCESS '
    ' Em caso de correçoes reportar a origem para atualizar o codigo'
    '---------------------------------------------------------------'
    Dim doc As DOMDocument
    Dim xDet As IXMLDOMNodeList
    Dim NomeArq As String
    Dim DB As Database
    Dim rsFor, rsProd, rsCompra, rsCompDet As DAO.Recordset
    Dim xProd As String
    Dim i, x, regAtual As Integer
    DoCmd.OpenForm "frmAguarde"
    Forms!frmaguarde!txt2 = "Xml Com Erros:"
    Diret = LocalXml
    NomeArq = Dir(Diret & "*.XML", vbArchive)

    Set DB = CurrentDb()
    Set doc = New DOMDocument

    'Buscará todos os arquivos com extenção .xml da pasta selecionada
    Do While NomeArq <> ""
    doc.Load (LocalXml & NomeArq) 'Pega a Pasta e o Nome do primeiro arquivo....
    'Verifica se o Arquivo foi aberto corretamente e se possui chave. Se possuir importa, se nao Pula pra o Proximo!
    If doc.validate.errorCode = -1072897500 And (doc.getElementsByTagName("chNFe").length) Then
    Set xDet = doc.getElementsByTagName("det")
    '------------------------------------------------------------------------'
    'Insere os Dados do Fornecedor, se nao for Cadastrado.
    Set rsFor = DB.OpenRecordset("tbFornecedores")
    x = Nz(DLookup("IdFor", "tbFornecedores", "Cnpj = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'X buscará o fornecedor na tabela "tbFornecedores"
    If x <= 0 Then 'Se x for <=0 significa que nao ta cadastrado, entao irá cadastrar o fornecedor
    rsFor.AddNew
    rsFor!NomeForn = doc.getElementsByTagName("xNome")(0).Text
    rsFor!CNPJ = doc.getElementsByTagName("CNPJ")(0).Text
    rsFor.Update
    'Apos cadastrar o fornecedor, x buscara o ID desse fornecedor para ser utilizado na importação do xml em questao
    x = Nz(DLookup("IdFor", "tbFornecedores", "Cnpj = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0)
    rsFor.Close
    Set rsFor = Nothing
    End If
    '------------------------------------------------------------------------'
    'Dados Principais da Nota de Compra (tbCompras)
    Set rsCompra = DB.OpenRecordset("tbCompras")
    rsCompra.AddNew
    rsCompra!IdFornecedor = x
    'Necessario essa verificação pois na versao XML 1.10 era somente Data (dEmi) ja na 3.0 mudou para DataHora (dhEmi)
    If (doc.getElementsByTagName("dhEmi").length) Then
    rsCompra!DataCompra = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
    Else
    rsCompra!DataCompra = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
    End If
    'Passa os totais da NFe para a variavel xProd
    xProd = doc.getElementsByTagName("total")(0).XML
    'Valor Bruto sem desconto
    rsCompra!ValorNFB = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    'Valor Liquido "Valor Bruto-descontos"
    rsCompra!ValorNFL = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")

    rsCompra!NumNF = doc.getElementsByTagName("nNF")(0).Text
    rsCompra!ChaveNF = doc.getElementsByTagName("chNFe")(0).Text
    rsCompra.Update
    regAtual = Nz(DLookup("ID", "tbCompras", "ChaveNF = '" & doc.getElementsByTagName("chNFe")(0).Text & "'"), 0)

    rsCompra.Close
    Set rsCompra = Nothing
    '------------------------------------------------------------------------'
    ' Dados dos Produtos
    i = 0
    xProd = ""
    'Aqui é o Loop que percorrerá pela Tag "det" que são os produtos..
    'Buscara produto a produto, e o inserirá na nota que esta sendo importada
    For Each det In xDet
    xProd = doc.getElementsByTagName("det")(i).XML ' xProd desmembrará o xml pegando produto a produto...
    x = Nz(DLookup("IdProd", "tbCadProd", "DescProd = '" & separaEntreDuasStringsXML(xProd, "", "") & "'"), 0)
    If x <= 0 Then
    'Cadastra o Produto, pois ainda nao foi cadastrado
    Set rsProd = DB.OpenRecordset("tbCadProd")
    rsProd.AddNew
    rsProd!DescProd = separaEntreDuasStringsXML(xProd, "", "")
    rsProd!Unid = separaEntreDuasStringsXML(xProd, "", "")
    rsProd!Estoque = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsProd.Update
    x = Nz(DLookup("IdProd", "tbCadProd", "DescProd = '" & separaEntreDuasStringsXML(xProd, "", "") & "'"), 0)
    'Insere o produto cadastrado na Nota de compra
    Set rsCompDet = DB.OpenRecordset("tbComprasDet")
    rsCompDet.AddNew
    rsCompDet!IDCompra = regAtual
    rsCompDet!IDProd = x
    rsCompDet!Qnt = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsCompDet!ValorUnit = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsCompDet!ValorTot = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",") * Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsCompDet!ICMS = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsCompDet.Update

    rsCompDet.Close
    rsProd.Close
    Set rsCompDet = Nothing
    Set rsProd = Nothing
    Else
    Set rsProd = DB.OpenRecordset("SELECT * FROM tbCadProd WHERE IdProd = " & x & "")
    rsProd.Edit 'Atualiza o estoque do produto
    rsProd!Estoque = rsProd!Estoque + Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsProd.Update
    'Insere o produto que ja estava cadastrado na Nota de compra
    Set rsCompDet = DB.OpenRecordset("tbComprasDet")
    rsCompDet.AddNew
    rsCompDet!IDCompra = regAtual
    rsCompDet!IDProd = x
    rsCompDet!Qnt = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",") 'O replace e utilizado para substituir o . por ,
    rsCompDet!ValorUnit = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsCompDet!ValorTot = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",") * Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsCompDet!ICMS = Nz(Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ","), 0)
    rsCompDet.Update
    'Limpa os dados do recordset e fecha a conecção
    rsCompDet.Close
    rsProd.Close
    Set rsCompDet = Nothing
    Set rsProd = Nothing
    End If
    'Add 1 unidade ao contador para pegar o proximo produto
    i = i + 1
    Next
    Else
    'Se abrir xml com erro, será add no formulario "aguarde" o nome dele
    Forms!frmaguarde!txt2 = Forms!frmaguarde!txt2 & vbNewLine & NomeArq
    Forms!frmaguarde.Requery
    End If
    'Loop dos arquivos, pega o proximo arquivo
    NomeArq = Dir()
    Loop
    Forms!frmCompras.Requery
    MsgBox "Todos os XMLs da pasta selecionada Foram Importados com Sucesso! " & vbNewLine & "Verifique as Notas lançadas!!!", vbInformation, "Sucesso!!!"
    DB.Close
    Set DB = Nothing
    End Function
    FabioPaes
    FabioPaes
    Maximo VIP
    Maximo VIP

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 3914
    Registrado : 14/08/2013

    [Resolvido]Importar Xml Lote "Importar Duplicata" Empty Re: [Resolvido]Importar Xml Lote "Importar Duplicata"

    Mensagem  FabioPaes 24/2/2017, 18:04

    Amigo, para importar as Duplicatas de cada XML, deverá fazer o mesmo que foi feito com os Produtos.

    Veja que nessa Linha, (   xProd = doc.getElementsByTagName("det")(i).XML    ) eu Desmembro o XML buscando os produtos tag . Como pode ter mais de um produto eu realizo o desmembramento informando a posição que quero (de 0 a xxx) pegando o valor da variável i ( (i).XML ). Assim a medida que e realizado o Loop eu irei descendo e pegando produto a aproduto. produto 0, 1, 2...

    Veja a Imagem a baixo:

    [Resolvido]Importar Xml Lote "Importar Duplicata" Duplic10


    Quanto ao Transporte e mais simples, pois é Unico... Então basta realizar a extração dos dados conforme realizei com os dados do Fornecedor...
    Veja onde estão os dados:
    [Resolvido]Importar Xml Lote "Importar Duplicata" Transp10


    .................................................................................
    _____________________________________________________________________
    Achou a solução para sua dúvida? Não seja Egoísta, Compartilhe com todos!
    A dica do Colega foi útil? Agradeça!

    O importante não saber tudo, mas sim a Onde procurar!
    avatar
    NADIRONUNES
    Super Avançado
    Super Avançado

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 508
    Registrado : 30/08/2010

    [Resolvido]Importar Xml Lote "Importar Duplicata" Empty Re: [Resolvido]Importar Xml Lote "Importar Duplicata"

    Mensagem  NADIRONUNES 24/2/2017, 18:49

    obrigado FabioPaes
    avatar
    NADIRONUNES
    Super Avançado
    Super Avançado

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 508
    Registrado : 30/08/2010

    [Resolvido]Importar Xml Lote "Importar Duplicata" Empty Re: [Resolvido]Importar Xml Lote "Importar Duplicata"

    Mensagem  NADIRONUNES 29/4/2017, 00:34

    como que busco  nesta xml  onde  tem o 799
    Anexos
    [Resolvido]Importar Xml Lote "Importar Duplicata" Attachmentdoc41823022000139_FCFBSX42M41NRUS2.zip
    Você não tem permissão para fazer download dos arquivos anexados.
    (1 Kb) Baixado 33 vez(es)
    avatar
    joaquim.oliveira903
    Novato
    Novato

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 11
    Registrado : 19/04/2016

    [Resolvido]Importar Xml Lote "Importar Duplicata" Empty não importa todas parcelas do xml

    Mensagem  joaquim.oliveira903 22/1/2019, 13:35

    Olá a todos, estou tentando importar as parcelas de xml através do o codigo do FabioPaes e fazendo a alterações que ele cita no link https://www.maximoaccess.com/t29427-resolvidoimportar-xml-lote-importar-duplicata .

    No entando, o xml ter várias parcelas e na tabela vem somente uma parcela. Gostaria da ajuda para deixar ele buscando e cadastrando todas as parcelas do xml. Peço ajuda por favor. Não entendo de VBA mas tentei seguir uma sequencia lógica que me levou a esse código abaixo:

    Option Compare Database
    Public Function ImportaXML(LocalXml As String)
    '---------------------------------------------------------------'
    '                Criado por FabioPaes                           '
    '           Em 12/02/2017 para MAXIMOACCESS                     '
    ' Em caso de correçoes reportar a origem para atualizar o codigo'
    '---------------------------------------------------------------'
    Dim doc As DOMDocument
    Dim xDet As IXMLDOMNodeList
    Dim xCobr As IXMLDOMNodeList
    Dim NomeArq As String
    Dim DB As Database
    Dim rsFor, rsProd, rsCompra, rsDup, rsCompDet As DAO.Recordset
    Dim xProd As String
    Dim xDup As String
    Dim i, x, regAtual As Integer
    DoCmd.OpenForm "frmAguarde"
    Forms!frmaguarde!txt2 = "Xml Com Erros:"
    Diret = LocalXml
    NomeArq = Dir(Diret & "*.XML", vbArchive)

    Set DB = CurrentDb()
    Set doc = New DOMDocument

    'Buscará todos os arquivos com extenção .xml da pasta selecionada
    Do While NomeArq <> ""
    doc.Load (LocalXml & NomeArq) 'Pega a Pasta e o Nome do primeiro arquivo....
    'Verifica se o Arquivo foi aberto corretamente e se possui chave. Se possuir importa, se nao Pula pra o Proximo!
    If doc.validate.errorCode = -1072897500 And (doc.getElementsByTagName("chNFe").length) Then
    Set xDet = doc.getElementsByTagName("det")
    Set xCobr = doc.getElementsByTagName("cobr")
    '------------------------------------------------------------------------'
    'Insere os Dados do Fornecedor, se nao for Cadastrado.
    Set rsFor = DB.OpenRecordset("tbFornecedores")
    x = Nz(DLookup("IdFor", "tbFornecedores", "Cnpj = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'X buscará o fornecedor na tabela "tbFornecedores"
    If x <= 0 Then 'Se x for <=0 significa que nao ta cadastrado, entao irá cadastrar o fornecedor
       rsFor.AddNew
           rsFor!NomeForn = doc.getElementsByTagName("xNome")(0).Text
           rsFor!CNPJ = doc.getElementsByTagName("CNPJ")(0).Text
       rsFor.Update
    'Apos cadastrar o fornecedor, x buscara o ID desse fornecedor para ser utilizado na importação do xml em questao
    x = Nz(DLookup("IdFor", "tbFornecedores", "Cnpj = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0)
    rsFor.Close
    Set rsFor = Nothing
    End If
    '------------------------------------------------------------------------'
    'Dados Principais da Nota de Compra (tbCompras)
    Set rsCompra = DB.OpenRecordset("tbCompras")
    rsCompra.AddNew
       rsCompra!IdFornecedor = x
       'Necessario essa verificação pois na versao XML 1.10 era somente Data (dEmi) ja na 3.0 mudou para DataHora (dhEmi)
       If (doc.getElementsByTagName("dhEmi").length) Then
       rsCompra!DataCompra = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
       Else
       rsCompra!DataCompra = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
       End If
           'Passa os totais da NFe para a variavel xProd
           xProd = doc.getElementsByTagName("total")(0).XML
           'Valor Bruto sem desconto
           rsCompra!ValorNFB = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
           'Valor Liquido "Valor Bruto-descontos"
           rsCompra!ValorNFL = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
       
       rsCompra!NumNF = doc.getElementsByTagName("nNF")(0).Text
       rsCompra!ChaveNF = doc.getElementsByTagName("chNFe")(0).Text
    rsCompra.Update
    regAtual = Nz(DLookup("ID", "tbCompras", "ChaveNF = '" & doc.getElementsByTagName("chNFe")(0).Text & "'"), 0)

    rsCompra.Close
    Set rsCompra = Nothing

    '------------------------------------------------------------------------------------------


    Set rsDup = DB.OpenRecordset("tbDup")
       rsDup.AddNew
           rsDup!ndup = Replace(separaEntreDuasStringsXML(xDup, "", ""), ".", ",")
           rsDup!vdup = Replace(separaEntreDuasStringsXML(xDup, "", ""), ".", ",")
           rsDup!dVenc = Replace(separaEntreDuasStringsXML(xDup, "", ""), ".", ",")
       rsDup.Update
    'Apos cadastrar o fornecedor, x buscara o ID desse fornecedor para ser utilizado na importação do xml em questao

    rsDup.Close
    Set rsDup = Nothing



    '----------------------------------------

    ' Dados dos Produtos
    i = 0
    i1 = 0
    xProd = ""
    xDup = ""
    'Aqui é o Loop que percorrerá pela Tag "det" que são os produtos..
    'Buscara produto a produto, e o inserirá na nota que esta sendo importada
    For Each det In xDet
    xProd = doc.getElementsByTagName("det")(i).XML ' xProd desmembrará o xml pegando produto a produto...
    xDup = doc.getElementsByTagName("cobr")(i1).XML '
    x = Nz(DLookup("IdProd", "tbCadProd", "DescProd = '" & separaEntreDuasStringsXML(xProd, "", "") & "'"), 0)
    If x <= 0 Then
    'Cadastra o Produto, pois ainda nao foi cadastrado
    Set rsProd = DB.OpenRecordset("tbCadProd")
    rsProd.AddNew
       rsProd!DescProd = separaEntreDuasStringsXML(xProd, "", "")
       rsProd!Unid = separaEntreDuasStringsXML(xProd, "", "")
       rsProd!Estoque = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsProd.Update
    x = Nz(DLookup("IdProd", "tbCadProd", "DescProd = '" & separaEntreDuasStringsXML(xProd, "", "") & "'"), 0)
    'Insere o produto cadastrado na Nota de compra
    Set rsCompDet = DB.OpenRecordset("tbComprasDet")
    rsCompDet.AddNew
       rsCompDet!IDCompra = regAtual
       rsCompDet!IDProd = x
       rsCompDet!Qnt = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
       rsCompDet!ValorUnit = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
       rsCompDet!ValorTot = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",") * Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
       rsCompDet!ICMS = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsCompDet.Update

    rsCompDet.Close
    rsProd.Close
    Set rsCompDet = Nothing
    Set rsProd = Nothing
    Else
    Set rsProd = DB.OpenRecordset("SELECT * FROM tbCadProd WHERE IdProd = " & x & "")
    rsProd.Edit 'Atualiza o estoque do produto
       rsProd!Estoque = rsProd!Estoque + Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
    rsProd.Update
    'Insere o produto que ja estava cadastrado na Nota de compra
    Set rsCompDet = DB.OpenRecordset("tbComprasDet")
    rsCompDet.AddNew
       rsCompDet!IDCompra = regAtual
       rsCompDet!IDProd = x
       rsCompDet!Qnt = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",") 'O replace e utilizado para substituir o . por ,
       rsCompDet!ValorUnit = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
       rsCompDet!ValorTot = Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",") * Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ",")
       rsCompDet!ICMS = Nz(Replace(separaEntreDuasStringsXML(xProd, "", ""), ".", ","), 0)
    rsCompDet.Update
    'Limpa os dados do recordset e fecha a conecção
    rsCompDet.Close
    rsProd.Close
    Set rsCompDet = Nothing
    Set rsProd = Nothing
    End If
    'Add 1 unidade ao contador para pegar o proximo produto
    i = i + 1
    Next
    Else
    'Se abrir xml com erro, será add no formulario "aguarde" o nome dele
    Forms!frmaguarde!txt2 = Forms!frmaguarde!txt2 & vbNewLine & NomeArq
    Forms!frmaguarde.Requery
    End If
    'Loop dos arquivos, pega o proximo arquivo
    NomeArq = Dir()
    Loop
    Forms!frmCompras.Requery
    MsgBox "Todos os XMLs da pasta selecionada Foram Importados com Sucesso! " & vbNewLine & "Verifique as Notas lançadas!!!", vbInformation, "Sucesso!!!"
    DB.Close
    Set DB = Nothing
    End Function

    Por favor me ajudem.

      Data/hora atual: 1/8/2021, 12:26