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

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

Olá Evandro,

Veja tópico abaixo, será só ajustar:
https://www.maximoaccess.com/t9595-resolvidoabrir-uma-pasta-diretorio-escolher-arquivo-a-carregar-para-importacao

Abraço

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

Olá,

Vou ver o que posso fazer

Abraço

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

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