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


    Importar apenas 1 XML selecionado de exemplo - função de importação do xml

    avatar
    evandropf
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 9
    Registrado : 03/12/2015

    Importar apenas 1 XML selecionado de exemplo -  função de importação do xml Empty Importar apenas 1 XML selecionado de exemplo - função de importação do xml

    Mensagem  evandropf em 31/1/2019, 10:16

    Bom dia pessoal estou fazendo alguns testes com a função de importação de xml desenvolvida por um membro da comunidade (FabioPaes),
    porem pelo que verifiquei a função importa xml em lote. Seria possivel informar um xml especifico e o sistema importar somente esse xml informado ?

    estou usando essa função para localizar o xml especifico:

    Código:
    Dim strCAMINHO As String
    On Error Resume Next
    txtLocalXML = ""
    strCAMINHO = localizarArquivo("C:\xml")
    If IsNull(strCAMINHO) Or strCAMINHO = "" Then Exit Sub
    If IsNull(Me.txtLocalXML) Or Me.txtLocalXML = "" Then
    txtLocalXML = strCAMINHO
    Else
      txtLocalXML = txtLocalXML & ";" & strCAMINHO
    End If




    abaixo função de importação do xml:


    Public Function ImportaXMLNovo(LocalXml As String)
    On Error Resume Next
    '---------------------------------------------------------------'
    '                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 xDup As IXMLDOMNodeList
    Dim xICMSTot As IXMLDOMNodeList
    Dim NomeArq As String
    Dim DB As Database
    Dim rsFornecedores, rsProdutos, rsCompras, rsComprasDetalhes, rsComprasPgto, rsValor, rsParcela As DAO.Recordset

    Dim cProd As String
    Dim cDup As String
    Dim cICMSTot As String
    Dim i, x, d, t, v, regAtual As Integer
    DoCmd.OpenForm "fml_AguardeXML"
    Forms!fml_AguardeXML!txt_erros = "Xml Com Erros:"
    Diret = LocalXml
    'NomeArq = Dir(Diret & "*.XML", vbArchive)
    NomeArq = strCAMINHO

    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.
    If doc.validate.errorCode = -1072897500 And (doc.getElementsByTagName("chNFe").length) Then 'If_001 Verifica se o Arquivo foi aberto corretamente e se possui chave. Se possuir importa, se nao Pula pra o Proximo!
    Set xDet = doc.getElementsByTagName("det")
    Set xDup = doc.getElementsByTagName("dup")
    Set xICMSTot = doc.getElementsByTagName("ICMSTot")

    '********************Insere os Dados do Fornecedor, se nao for Cadastrado.********************

    Set rsFor = DB.OpenRecordset("Fornecedores")
    x = Nz(DLookup("CodFornecedor", "Fornecedores", "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!NomeFantasia = doc.getElementsByTagName("xFant")(0).Text
           rsFor!RazaoSocial = doc.getElementsByTagName("xNome")(0).Text
           rsFor!CNPJ = doc.getElementsByTagName("CNPJ")(0).Text
           rsFor!InscEstadual = doc.getElementsByTagName("IE")(0).Text
           rsFor!Endereco = doc.getElementsByTagName("xLgr")(0).Text & " N:" & doc.getElementsByTagName("nro")(0).Text
           rsFor!Bairro = doc.getElementsByTagName("xBairro")(0).Text
           rsFor!Cidade = doc.getElementsByTagName("xMun")(0).Text
           rsFor!UF = doc.getElementsByTagName("UF")(0).Text
           rsFor!Cep = doc.getElementsByTagName("CEP")(0).Text
           rsFor!Telefone = doc.getElementsByTagName("fone")(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("CodFornecedor", "Fornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0)
    rsFor.Close
    Set rsFor = Nothing
    End If 'If_002

    '********************Insere o dados do tipo de pagamento, se não for cadastrado********************

    'Set rsTipoPgto = DB.OpenRecordset("tbl_CadTipoPagamentos")
    't = Nz(DLookup("COD_tbl_CadTipoPagamentos", "tbl_CadTipoPagamentos", "TIPO_NFE = '" & doc.getElementsByTagName("infCpl")(0).Text & "'"), 0) 't buscará a forma de pgto na tabela "tbl_CadTipoPagamentos"

    'If t <= 0 Then 'If_003
    '   rsTipoPgto.AddNew
    '        rsTipoPgto!Tipo_Pagamento = doc.getElementsByTagName("infCpl")(0).Text
    '        rsTipoPgto!TIPO_NFE = doc.getElementsByTagName("infCpl")(0).Text
    '    rsTipoPgto.Update
       
    't = Nz(DLookup("COD_tbl_CadTipoPagamentos", "tbl_CadTipoPagamentos", "TIPO_NFE = '" & doc.getElementsByTagName("infCpl")(0).Text & "'"), 0) 'Apos cadastrar o tipo pgto, t buscara o ID desse tipo para ser utilizado na importação do xml em questao
    'rsTipoPgto.Close
    'Set rsTipoPgto = Nothing
    'End If 'If 003

    '********************Dados Principais da Nota de Compra (tbl_CadCompras)********************

    v = 0
    cICMSTot = ""
    cICMSTot = doc.getElementsByTagName("ICMSTot")(v).XML
    'xTipo = Nz(DLookup("COD_tbl_CadTipoPagamentos", "tbl_CadTipoPagamentos", "TIPO_NFE = '" & doc.getElementsByTagName("infCpl")(0).Text & "'"), 0) 'x buscará a forma de pgto na tabela "tbl_CadTipoPagamentos"

    Set rsCompras = DB.OpenRecordset("tbCompras")
    rsCompras.AddNew
        rsCompras!NumNF = doc.getElementsByTagName("nNF")(0).Text
       '**********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 'If_004
       rsCompras!DataCompra = Format(left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
       'rsCompra!emissaoNF = Format(doc.getElementsByTagName("dSaiEnt")(0).Text, "dd/mm/yyyy")
       Else
       rsCompras!DataCompra = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
       rsCompras!emissaoNF = Format(doc.getElementsByTagName("dSaiEnt")(0).Text, "dd/mm/yyyy")
       End If 'If_004
       rsCompras!IdFornecedor = x
       rsCompras!ChaveNF = doc.getElementsByTagName("chNFe")(0).Text
       rsCompras!CNPJ_for = doc.getElementsByTagName("CNPJ")(0).Text
       rsCompras!IE_for = doc.getElementsByTagName("IE")(0).Text
       rsCompras!CFOP = doc.getElementsByTagName("CFOP")(0).Text
       rsCompras!ValidacaoNF = doc.getElementsByTagName("CNPJ")(0).Text & doc.getElementsByTagName("nNF")(0).Text

    'Valor Bruto sem desconto
    rsCompras!ValorNFB = doc.getElementsByTagName("vBC")(0).Text
    'Valor Liquido "Valor Bruto-descontos"
    'rsCompras!ValorNFL = doc.getElementsByTagName("vNF")(0).Text
    rsCompras!ValorNFL = doc.getElementsByTagName("vNF")(0).Text / 100



       rsCompras!Nome_Fornecedor = doc.getElementsByTagName("xNome")(0).Text
       
       rsCompras.Update
    regAtual = Nz(DLookup("ID", "tbCompras", "NumNF = '" & doc.getElementsByTagName("nNF")(0).Text & "'"), 0)
    rsCompras.Close
    Set rsCompras = Nothing

    '********************Dados dos Produtos********************

    i = 0
    d = 0
    cProd = ""
    cDup = ""
    '**********Aqui é o Loop que percorrerá pela Tag "det" que são os produtos. Buscar produto a produto, e o inserirá na nota que esta sendo importada**********
    For Each det In xDet
    cProd = doc.getElementsByTagName("det")(i).XML ' cProd desmembrará o xml pegando produto a produto...
    x = Nz(DLookup("CodProduto", "Produtos", "CodProduto = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)

       '**********Cadastra o Produto, pois ainda nao foi cadastrado**********
    If x <= 0 Then 'If_005
    Set rsProdutos = DB.OpenRecordset("Produtos")
    xFornecedor = Nz(DLookup("CodFornecedor", "Fornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'X buscará o fornecedor na tabela "tbl_CadFornecedores"
    xLucro = Nz(DLookup("Lucro", "Produtos", "CodProduto = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
    xValorCompra = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",")
    xValorVenda = (xValorCompra * 100) / 70
    'Nz (DMax("CDbl([Produtos])", "CodProduto"))
    rsProdutos.AddNew
       rsProdutos!CodProduto = Nz(DMax("CDbl([CodProduto])", "Produtos")) + 1
       rsProdutos!CodProdutoN = separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>")
       rsProdutos!Descricao = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
       rsProdutos!Unidade_Medida = separaEntreDuasStringsXML(cProd, "<uCom>", "</uCom>")
       rsProdutos!EAN13 = separaEntreDuasStringsXML(cProd, "<cEAN>", "</cEAN>")
       rsProdutos!EAN14DUM = separaEntreDuasStringsXML(cProd, "<cEANTrib>", "</cEANTrib>")
       
       rsProdutos!Fornecedor = xFornecedor
       rsProdutos!PrecoCusto = xValorCompra
       rsProdutos!CustoMedio = xValorCompra
       rsProdutos!Estoque = Replace(separaEntreDuasStringsXML(cProd, "<qCom>", "</qCom>"), ".", ",")
       rsProdutos!PrecoVenda = xValorVenda
       rsProdutos!PrecoPrazo = xValorVenda
       
       rsProdutos!NCM = separaEntreDuasStringsXML(cProd, "<NCM>", "</NCM>")
       rsProdutos!CEST = separaEntreDuasStringsXML(cProd, "<CST>", "</CST>")
       rsProdutos!pICMS = separaEntreDuasStringsXML(cProd, "<pICMS>", "</pICMS>")
       
    rsProdutos.Update
    Else
       '**********Ajusta os valores de compra e venda do produto se ele já estiver cadastrado.**********
    xValorCompra = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",")
    xValorVenda = (xValorCompra * 100) / 70

       Set rsProdutos = DB.OpenRecordset("select PrecoCusto,CodProduto from Produtos where CodProduto = " & x & "")
       
       rsProdutos.Edit
       rsProdutos("PrecoCusto") = xValorCompra
       rsProdutos.Update
       rsProdutos.Close
       
       Set rsProdutos = DB.OpenRecordset("select PrecoVenda, CodProduto from Produtos where CodProduto = " & x & "")
       
       rsProdutos.Edit
       rsProdutos("PrecoVenda") = xValorVenda
       rsProdutos.Update
       rsProdutos.Close
       
    End If 'If_005

    x = Nz(DLookup("CodProduto", "Produtos", "CodProduto = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
       '**********Insere o produto cadastrado na Nota de compra**********
    Set rsComprasDetalhes = DB.OpenRecordset("tbComprasDet")
    rsComprasDetalhes.AddNew
       'rsComprasDetalhes!COD_ME_tbl_CadCompras = regAtual
       'rsComprasDetalhes!COD_PRODUTO = x
       'rsComprasDetalhes!DESC_PRODUTO = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
       'rsComprasDetalhes!Quantidade = Replace(separaEntreDuasStringsXML(cProd, "<qCom>", "</qCom>"), ".", ",")
       'rsComprasDetalhes!PRECO_COMPRA = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",")
       'rsComprasDetalhes!CFOP_COMP = separaEntreDuasStringsXML(cProd, "<CFOP>", "</CFOP>")
       'rsComprasDetalhes!NCM_COMP = separaEntreDuasStringsXML(cProd, "<NCM>", "</NCM>")
       
       rsComprasDetalhes!IDCompra = regAtual
       rsComprasDetalhes!IdProd = x 'separaEntreDuasStringsXML(xProd, "<cProd>", "</cProd>")
       rsComprasDetalhes!IdForn = xFornecedor
       rsComprasDetalhes!CEST = separaEntreDuasStringsXML(cProd, "<CST>", "</CST>")
       rsComprasDetalhes!NCM = separaEntreDuasStringsXML(cProd, "<NCM>", "</NCM>")
       rsComprasDetalhes!cfop_prod = separaEntreDuasStringsXML(cProd, "<CFOP>", "</CFOP>")
       rsComprasDetalhes!DescritivoProd = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
       rsComprasDetalhes!Qnt = Replace(separaEntreDuasStringsXML(cProd, "<qCom>", "</qCom>"), ".", ",")
       rsComprasDetalhes!ValorUnit = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",")
       rsComprasDetalhes!ValorTot = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",") * Replace(separaEntreDuasStringsXML(cProd, "<qCom>", "</qCom>"), ".", ",")
       rsComprasDetalhes!ICMS = Replace(separaEntreDuasStringsXML(cProd, "<pICMS>", "</pICMS>"), ".", ",")

    rsComprasDetalhes.Update
    rsComprasDetalhes.Close

    Set rsComprasDetalhes = Nothing
    Set rsProdutos = Nothing
       '**********Add 1 unidade ao contador para pegar o proximo produto**********
    i = i + 1
    Next

    'nParc = "1"
    'xTipo = Nz(DLookup("COD_tbl_CadTipoPagamentos", "tbl_CadTipoPagamentos", "TIPO_NFE = '" & doc.getElementsByTagName("infCpl")(0).Text & "'"), 0) 'x buscará a forma de pgto na tabela "tbl_CadTipoPagamentos"

    For Each nDup In xDup
    cDup = doc.getElementsByTagName("dup")(d).XML ' cDup desmembrará o xml pegando boleto a boleto...

    'Set rsComprasPgto = DB.OpenRecordset("tbl_CadComprasPgto")
    'rsComprasPgto.AddNew
    '   rsComprasPgto!COD_ME_tbl_CadCompras = regAtual
    '    rsComprasPgto!NUM_PARCELA = nParc
     '  rsComprasPgto!DATA_PREV_PGTO = separaEntreDuasStringsXML(cDup, "<dVenc>", "</dVenc>")
    '   rsComprasPgto!VALOR_PARCELA = Replace(separaEntreDuasStringsXML(cDup, "<vDup>", "</vDup>"), ".", ",")
    '    rsComprasPgto!TIPO_PGTO = xTipo
    'rsComprasPgto.Update
    'rsComprasPgto.Close

    'Set rsComprasPgto = Nothing
       '**********Add 1 unidade ao contador para pegar o proximo boleto**********
    d = d + 1
    nParc = nParc + 1
    Next

    'Set rsParcela = DB.OpenRecordset("select QTDE_PARCELA, COD_tbl_CadCompras from tbl_CadCompras where COD_tbl_CadCompras = " & regAtual & "")
       
     '  rsParcela.Edit
      ' rsParcela("QTDE_PARCELA") = nParc - 1
      ' rsParcela.Update
      ' rsParcela.Close

    Else

    '********************Se abrir xml com erro, será add no formulario "aguarde" o nome dele********************

    Forms!fml_AguardeXML!txt_erros = Forms!fml_AguardeXML!txt_erros & vbNewLine & NomeArq
    Forms!fml_AguardeXML.Requery
    End If 'If_001

    '********************Loop dos arquivos, pega o proximo arquivo********************

    NomeArq = Dir()
    Loop

    Forms!tbCompras.Requery
    Forms!tbComprasDet.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
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6174
    Registrado : 15/03/2013

    Importar apenas 1 XML selecionado de exemplo -  função de importação do xml Empty Re: Importar apenas 1 XML selecionado de exemplo - função de importação do xml

    Mensagem  ahteixeira em 2/2/2019, 11:46

    avatar
    evandropf
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 9
    Registrado : 03/12/2015

    Importar apenas 1 XML selecionado de exemplo -  função de importação do xml Empty Re: Importar apenas 1 XML selecionado de exemplo - função de importação do xml

    Mensagem  evandropf em 2/2/2019, 13:15

    ahteixeira, obrigado pela resposta,
    consegui resolver o problema de informar o xml a ser importado o problema e o o processamento do xml que esta para pegar arquivos em lote se eu informo so o selecionado não processa a entrada se eu apago o aquivo e fica o caminho da pasta processa a entrada de todos os xmls.

    não estou conseguindo passar para processar somente o arquivo selecionado.

    obrigado.
    Evandro
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6174
    Registrado : 15/03/2013

    Importar apenas 1 XML selecionado de exemplo -  função de importação do xml Empty Re: Importar apenas 1 XML selecionado de exemplo - função de importação do xml

    Mensagem  ahteixeira em 7/2/2019, 14:52

    Olá,

    Vou ver o que posso fazer

    Abraço
    avatar
    evandropf
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 9
    Registrado : 03/12/2015

    Importar apenas 1 XML selecionado de exemplo -  função de importação do xml Empty Re: Importar apenas 1 XML selecionado de exemplo - função de importação do xml

    Mensagem  evandropf em 13/2/2019, 13:57

    obrigado, provisoriamente eu resolvi criando uma subpasta na pasta conde se encontra os xmls e movo o arquivo apos lido para essa pasta.

    retirei a opção de localizar a pasta de xml para não correr o risco de ler a pasta de xml ja lido anterirmente.
    e por enquanto da dando certo assim..rs

    obrigado
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6174
    Registrado : 15/03/2013

    Importar apenas 1 XML selecionado de exemplo -  função de importação do xml Empty Re: Importar apenas 1 XML selecionado de exemplo - função de importação do xml

    Mensagem  ahteixeira em 13/2/2019, 16:09

    Olá Evandro,

    Com o código abaixo, conseguimos selecionar o ficheiro, beste caso *.XML:
    Código:
    Private Sub btnSelecionarImportar_Click()
    'Alvaro Teixeira (ahteixeira) 2019 para MaximoAccess
    'Requer referencia a Microsoft Office XX.xx Object Library
        
        Dim fd As FileDialog
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        
        fd.Title = "Selecione um ficheiro"
        fd.InitialFileName = Application.CurrentProject.Path & "\"
        fd.Filters.Add "Ficheiro XML", "*.xml", 1

        fd.Show
        
        If (fd.SelectedItems.Count > 0) Then
            Call ImportaXML(fd.SelectedItems(1))
        Else
            MsgBox "Não foi selecionado nenhum ficheiro.", vbInformation, ""
        End If
    End Sub

    Depois foi ajustar o módulo ImportaXML do exemplo do colega Fabio Paes.

    Verifique as alterações:
    cld.pt/dl/download/82e39f11-a62c-440f-b274-e24447241ef7/ImportarUma-NFe-XML.zip

    Abraço

    Conteúdo patrocinado

    Importar apenas 1 XML selecionado de exemplo -  função de importação do xml Empty Re: Importar apenas 1 XML selecionado de exemplo - função de importação do xml

    Mensagem  Conteúdo patrocinado


      Data/hora atual: 20/7/2019, 11:15