[Resolvido]Erro ao importar XML

Boa tarde

Desde já agradeço qualquer ajuda.
Criei um sistema de vendas em Access 2007. Estou trabalhando agora na importação do XML das notas fiscais de compra de produtos para a tabela/formulário de compras.
Para isso, pesquisei sobre importação de xml e como resultado, na lista de repositório fiz o download de um exemplo do Fabio Paes. Agradeço a ele o exemplo disponibilizado:

https://www.maximoaccess.com/t29286-importar-todas-as-nfe-nota-fiscal-eletronica-xml-de-uma-pasta-versao-xml-1-10-2-00-e-3-10?highlight=nota+fiscal

Fiz algumas alterações no código em função de nomes de campos e preenchimentos a partir do XML. A parte do código que verifica e cadastra fornecedor, e dados principais do formulário de compras está OK. Realizei testes disso, usando apóstrofo nas linhas que eu ainda não tinha ajustado, ficando para um segundo momento somente a parte de produtos a serem cadastrados.
Após concluir essa parte, tentei fazer a importação do XML, porém recebo o erro:

Erro em tempo de execução '3420': O objeto não é válido ou não está definido.

Ao clicar em depurar, o VBA mostra essa linha do código:

Set rsComprasDetalhes = DB.OpenRecordset("tbl_CadComprasDetalhes")

Pela mensagem de erro, fiz algumas pesquisas mas não identifiquei o erro ainda. Pelo erro "não está definido", verifiquei essa linha do código:

Dim rsFornecedores, rsProdutos, rsCompras, rsComprasDetalhes As DAO.Recordset

O nome está correto. Verifiquei também o nome da tabela, e pelo que vejo está correto. Segue o código.

Código:

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 NomeArq As String
Dim DB As Database
Dim rsFornecedores, rsProdutos, rsCompras, rsComprasDetalhes As DAO.Recordset
Dim cProd As String
Dim i, x, regAtual As Integer
DoCmd.OpenForm "fml_AguardeXML"
Forms!fml_AguardeXML!txt_erros = "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.
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")

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

Set rsFornecedores = DB.OpenRecordset("tbl_CadFornecedores")
x = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'x buscará o fornecedor na tabela "tbl_CadFornecedores"
xCidade = Nz(DLookup("COD_tbl_CadCidades", "tbl_CadCidades", "CIDADE = '" & doc.getElementsByTagName("xMun")(0).Text & "'"), 0) 'x buscará a cidade na tabela "tbl_CadCidades"

If x <= 0 Then 'If_002 Se x for <=0 significa que não está cadastrado, então irá cadastrar o fornecedor
    rsFornecedores.AddNew
        rsFornecedores!NOME_FORNECEDOR = doc.getElementsByTagName("xFant")(0).Text
        rsFornecedores!RAZAO_SOCIAL = doc.getElementsByTagName("xNome")(0).Text
        rsFornecedores!CNPJ = doc.getElementsByTagName("CNPJ")(0).Text
        rsFornecedores!INSCR_EST = doc.getElementsByTagName("IE")(0).Text
        rsFornecedores!END_FORN = doc.getElementsByTagName("xLgr")(0).Text
        rsFornecedores!CIDADE_FORN = xCidade
        rsFornecedores!NUM_END_FORN = doc.getElementsByTagName("nro")(0).Text
        rsFornecedores!ESTADO_FORN = doc.getElementsByTagName("UF")(0).Text
        rsFornecedores!CEP_FORN = doc.getElementsByTagName("CEP")(0).Text
        rsFornecedores!TELEFONE = doc.getElementsByTagName("fone")(0).Text
    rsFornecedores.Update

x = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'Apos cadastrar o fornecedor, x buscara o ID desse fornecedor para ser utilizado na importação do xml em questao
rsFornecedores.Close
Set rsFornecedores = Nothing
End If 'If_002

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

xTipo = "2"
Set rsCompras = DB.OpenRecordset("tbl_CadCompras")
rsCompras.AddNew
    rsCompras!CHAVE_TBL = "CO"
    rsCompras!NUM_PEDIDO = 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_003
    rsCompras!DATA_PEDIDO = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
    Else
    rsCompras!DATA_PEDIDO = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
    End If 'If_003
    rsCompras!FORNECEDOR = x
    rsCompras!DATA_1A_PARCELA = doc.getElementsByTagName("dVenc")(0).Text
    rsCompras!TIPO_PGTO = xTipo
    rsCompras.QTDE_PARCELA = "1"
    rsCompras.VALOR_BOLETO = "1,30"
    rsCompras.Update
regAtual = Nz(DLookup("COD_tbl_CadCompras", "tbl_CadCompras", "NUM_PEDIDO = '" & doc.getElementsByTagName("nNF")(0).Text & "'"), 0)
rsCompras.Close
Set rsCompras = Nothing

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

i = 0
cProd = ""
'**********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("COD_tbl_CadProdutos", "tbl_CadProdutos", "COD_PRODUTO = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
    '**********Cadastra o Produto, pois ainda nao foi cadastrado**********
If x <= 0 Then 'If_004
Set rsProdutos = DB.OpenRecordset("tbl_CadProdutos")
xFornecedor = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'X buscará o fornecedor na tabela "tbl_CadFornecedores"
xValorCompra = separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>")
xValorVenda = (xValorCompra * 100) / 70
rsProdutos.AddNew
    rsProdutos!COD_PRODUTO = separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>")
    rsProdutos!DESCRICAO_PRODUTO = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
    rsProdutos!DESCRICAO_NFE = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
    rsProdutos!NOME_FORNECEDOR = xFornecedor
    rsProdutos!VALOR_COMPRA = separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>")
    rsProdutos!VALOR_VENDA = xValorVenda
rsProdutos.Update
Else
    '**********Ajusta os valores de compra e venda do produto se ele já estiver cadastrado.**********
xValorCompra = separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>")
xValorVenda = (xValorCompra * 100) / 70
Dim rsValor As Recordset

    Set DB = CurrentDb
    Set rsValor = DB.OpenRecordset("select VALOR_COMPRA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
    
    rsValor.Edit
    rsValor("VALOR_COMPRA") = xValorCompra
    rsValor.Update
    rsValor.Close
DB.Close

    Set DB = CurrentDb
    Set rsValor = DB.OpenRecordset("select VALOR_VENDA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
    
    rsValor.Edit
    rsValor("VALOR_VENDA") = xValorVenda
    rsValor.Update
    rsValor.Close
DB.Close
End If 'If_004
x = Nz(DLookup("COD_tbl_CadProdutos", "tbl_CadProdutos", "COD_PRODUTO = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
    '**********Insere o produto cadastrado na Nota de compra**********
Set rsComprasDetalhes = DB.OpenRecordset("tbl_CadComprasDetalhes")
rsComprasDetalhes.AddNew
    rsComprasDetalhes!COD_ME_tbl_CadCompras = regAtual
    rsComprasDetalhes!COD_PRODUTO = x
    rsComprasDetalhes!DESC_PRODUTO = Replace(separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>"), ".", ",")
    rsComprasDetalhes!QUANTIDADE = Replace(separaEntreDuasStringsXML(cProd, "<qCom>", "</qCom>"), ".", ",")
    rsComprasDetalhes!PRECO_COMPRA = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",")
rsComprasDetalhes.Update
rsComprasDetalhes.Close
rsProdutos.Close
Set rsComprasDetalhes = Nothing
Set rsProdutos = Nothing
    '**********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!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!fml_CadCompras.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


O banco está em anexo, junto com o XML de uma nota.

Obrigado.

Enio Eltz Filho.

Ola, amigo uma verificada Rápida percebi que você deu uma perdida no codigo...

O Motivo do erro é que a Variável BD (que define a qual BD iremos consultar) está fechada (Não definida) na hora que tenta abrir o recordset do detalhe da compra... Isso ocorre porque nas linhas anteriores ao do erro vc fechou por diversas vezes a Variavel BD (DB.Cloes).

Não ha a necessidade de fechar essa variável, pois sempre usaremos o mesmo BD... So havendo a necessidade de fechar ela no final do Codigo.


Corrija, substituindo por esse:

Código:


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 rsFornecedores, rsProdutos, rsCompras, rsComprasDetalhes As DAO.Recordset

Dim rsValor As Recordset

Dim cProd As String
Dim i, x, regAtual As Integer
DoCmd.OpenForm "fml_AguardeXML"
Forms!fml_AguardeXML!txt_erros = "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.
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")

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

Set rsFornecedores = DB.OpenRecordset("tbl_CadFornecedores")
x = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'x buscará o fornecedor na tabela "tbl_CadFornecedores"
xCidade = Nz(DLookup("COD_tbl_CadCidades", "tbl_CadCidades", "CIDADE = '" & doc.getElementsByTagName("xMun")(0).Text & "'"), 0) 'x buscará a cidade na tabela "tbl_CadCidades"

If x <= 0 Then 'If_002 Se x for <=0 significa que não está cadastrado, então irá cadastrar o fornecedor
    rsFornecedores.AddNew
        rsFornecedores!NOME_FORNECEDOR = doc.getElementsByTagName("xFant")(0).Text
        rsFornecedores!RAZAO_SOCIAL = doc.getElementsByTagName("xNome")(0).Text
        rsFornecedores!CNPJ = doc.getElementsByTagName("CNPJ")(0).Text
        rsFornecedores!INSCR_EST = doc.getElementsByTagName("IE")(0).Text
        rsFornecedores!END_FORN = doc.getElementsByTagName("xLgr")(0).Text
        rsFornecedores!CIDADE_FORN = xCidade
        rsFornecedores!NUM_END_FORN = doc.getElementsByTagName("nro")(0).Text
        rsFornecedores!ESTADO_FORN = doc.getElementsByTagName("UF")(0).Text
        rsFornecedores!CEP_FORN = doc.getElementsByTagName("CEP")(0).Text
        rsFornecedores!TELEFONE = doc.getElementsByTagName("fone")(0).Text
    rsFornecedores.Update

x = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'Apos cadastrar o fornecedor, x buscara o ID desse fornecedor para ser utilizado na importação do xml em questao
rsFornecedores.Close
Set rsFornecedores = Nothing
End If 'If_002

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

xTipo = "2"
Set rsCompras = DB.OpenRecordset("tbl_CadCompras")
rsCompras.AddNew
    rsCompras!CHAVE_TBL = "CO"
    rsCompras!NUM_PEDIDO = 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_003
    rsCompras!DATA_PEDIDO = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
    Else
    rsCompras!DATA_PEDIDO = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
    End If 'If_003
    rsCompras!FORNECEDOR = x
    rsCompras!DATA_1A_PARCELA = doc.getElementsByTagName("dVenc")(0).Text
    rsCompras!TIPO_PGTO = xTipo
    rsCompras!QTDE_PARCELA = "1" 'Mudei aqui... Estava  rsCompras.QTDE_PARCELA onde na verdade deve informa com ! e nao com .
    rsCompras!VALOR_BOLETO = "1,30"
    rsCompras.Update
regAtual = Nz(DLookup("COD_tbl_CadCompras", "tbl_CadCompras", "NUM_PEDIDO = '" & doc.getElementsByTagName("nNF")(0).Text & "'"), 0)
rsCompras.Close
Set rsCompras = Nothing

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

i = 0
cProd = ""
'**********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("COD_tbl_CadProdutos", "tbl_CadProdutos", "COD_PRODUTO = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
    '**********Cadastra o Produto, pois ainda nao foi cadastrado**********
If x <= 0 Then 'If_004
Set rsProdutos = DB.OpenRecordset("tbl_CadProdutos")
xFornecedor = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'X buscará o fornecedor na tabela "tbl_CadFornecedores"
xValorCompra = separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>")
xValorVenda = (xValorCompra * 100) / 70
rsProdutos.AddNew
    rsProdutos!COD_PRODUTO = separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>")
    rsProdutos!DESCRICAO_PRODUTO = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
    rsProdutos!DESCRICAO_NFE = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
    rsProdutos!NOME_FORNECEDOR = xFornecedor
    rsProdutos!VALOR_COMPRA = separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>")
    rsProdutos!VALOR_VENDA = xValorVenda
rsProdutos.Update
Else
    '**********Ajusta os valores de compra e venda do produto se ele já estiver cadastrado.**********
xValorCompra = separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>")
xValorVenda = (xValorCompra * 100) / 70


    'Set DB = CurrentDb
    Set rsValor = DB.OpenRecordset("select VALOR_COMPRA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
    
    rsValor.Edit
    rsValor("VALOR_COMPRA") = xValorCompra
    rsValor.Update
    rsValor.Close
'DB.Close

    'Set DB = CurrentDb
    Set rsValor = DB.OpenRecordset("select VALOR_VENDA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
    
    rsValor.Edit
    rsValor("VALOR_VENDA") = xValorVenda
    rsValor.Update
    rsValor.Close
'DB.Close
End If 'If_004
x = Nz(DLookup("COD_tbl_CadProdutos", "tbl_CadProdutos", "COD_PRODUTO = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
    '**********Insere o produto cadastrado na Nota de compra**********
Set rsComprasDetalhes = DB.OpenRecordset("tbl_CadComprasDetalhes")
rsComprasDetalhes.AddNew
    rsComprasDetalhes!COD_ME_tbl_CadCompras = regAtual
    rsComprasDetalhes!COD_PRODUTO = x
    rsComprasDetalhes!DESC_PRODUTO = Replace(separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>"), ".", ",")
    rsComprasDetalhes!QUANTIDADE = Replace(separaEntreDuasStringsXML(cProd, "<qCom>", "</qCom>"), ".", ",")
    rsComprasDetalhes!PRECO_COMPRA = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",")
rsComprasDetalhes.Update
rsComprasDetalhes.Close
'rsProdutos.Close
Set rsComprasDetalhes = Nothing
Set rsProdutos = Nothing
    '**********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!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!fml_CadCompras.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



Veja que onde encontrei erros eu apenas comentei a linha, para que vc veja onde estava a errar.

Verifique mais a fundo se não ha erros, pois olhei muito Rápido suas mudanças!

Bom dia Fabio

Muito obrigado!!!!!
Realmente era a situação de fechar a variável BD.
Para que você entenda, esse sistema eu criei para minha esposa gerenciar as vendas dela. Aprendi bastante com isso, mas esse é um código mais complexo, e aprendi bastante com ele.
No código que eu mandei, há a parte que ajusta valores de compra e venda, e isso eu tenho em uso em um outro formulário:

   Set DB = CurrentDb
   Set rsValor = DB.OpenRecordset("select VALOR_COMPRA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
   
   rsValor.Edit
   rsValor("VALOR_COMPRA") = xValorCompra
   rsValor.Update
   rsValor.Close
DB.Close

Como eu copiei, ele "abriu" a variável BD que já estava aberta e depois fechou, criando o problema.
Mas é isso, estou aprendendo. Vou documentar isso para que não tenha problemas novamente.

Grande abraço!

Enio Eltz Filho.

Bacana! Faça bom proveito da Função!

Grato pelo retorno amigo, até a próxima se Deus Quiser!

Boa tarde

Estou enviando o código atualizado, pois tive que realizar uma alteração. O que estava acontecendo é que, ao importar, eu criei no código regras para atualizar o valor de compra e calcular o valor de venda. Mas o XML tem o valor com ponto antes das casas decimais. Por exemplo 2.5000000000000 para R$ 2,50. Ao importar, ele estava colocando os valor em bilhões de reais.

O problema era que no código, em linhas que buscam esse valor no XML estavam assim:

rsComprasDetalhes!PRECO_COMPRA = separaEntreDuasStringsXML(cProd, "", "")

Mas precisa ser assim:

rsComprasDetalhes!PRECO_COMPRA = Replace(separaEntreDuasStringsXML(cProd, "", ""), ".", ",")

Com o Replace antes, o código vai substituir o ponto pela vírgula. Alterei todas as linhas que buscam valores com ponto para esse formato. Não é difícil de entender o que ocorreu analisando o código, mas como tive grande ajuda nesse caso, compartilho a informação.

Código:

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 rsFornecedores, rsProdutos, rsCompras, rsComprasDetalhes As DAO.Recordset

Dim rsValor As Recordset

Dim cProd As String
Dim i, x, regAtual As Integer
DoCmd.OpenForm "fml_AguardeXML"
Forms!fml_AguardeXML!txt_erros = "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.
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")

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

Set rsFornecedores = DB.OpenRecordset("tbl_CadFornecedores")
x = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'x buscará o fornecedor na tabela "tbl_CadFornecedores"
xCidade = Nz(DLookup("COD_tbl_CadCidades", "tbl_CadCidades", "CIDADE = '" & doc.getElementsByTagName("xMun")(0).Text & "'"), 0) 'x buscará a cidade na tabela "tbl_CadCidades"

If x <= 0 Then 'If_002 Se x for <=0 significa que não está cadastrado, então irá cadastrar o fornecedor
    rsFornecedores.AddNew
        rsFornecedores!NOME_FORNECEDOR = doc.getElementsByTagName("xFant")(0).Text
        rsFornecedores!RAZAO_SOCIAL = doc.getElementsByTagName("xNome")(0).Text
        rsFornecedores!CNPJ = doc.getElementsByTagName("CNPJ")(0).Text
        rsFornecedores!INSCR_EST = doc.getElementsByTagName("IE")(0).Text
        rsFornecedores!END_FORN = doc.getElementsByTagName("xLgr")(0).Text
        rsFornecedores!CIDADE_FORN = xCidade
        rsFornecedores!NUM_END_FORN = doc.getElementsByTagName("nro")(0).Text
        rsFornecedores!ESTADO_FORN = doc.getElementsByTagName("UF")(0).Text
        rsFornecedores!CEP_FORN = doc.getElementsByTagName("CEP")(0).Text
        rsFornecedores!TELEFONE = doc.getElementsByTagName("fone")(0).Text
    rsFornecedores.Update

x = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'Apos cadastrar o fornecedor, x buscara o ID desse fornecedor para ser utilizado na importação do xml em questao
rsFornecedores.Close
Set rsFornecedores = Nothing
End If 'If_002

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

xTipo = "2"
Set rsCompras = DB.OpenRecordset("tbl_CadCompras")
rsCompras.AddNew
    rsCompras!CHAVE_TBL = "CO"
    rsCompras!NUM_PEDIDO = 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_003
    rsCompras!DATA_PEDIDO = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
    Else
    rsCompras!DATA_PEDIDO = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
    End If 'If_003
    rsCompras!FORNECEDOR = x
    rsCompras!DATA_1A_PARCELA = doc.getElementsByTagName("dVenc")(0).Text
    rsCompras!TIPO_PGTO = xTipo
    rsCompras!QTDE_PARCELA = "1"
    rsCompras!VALOR_BOLETO = "1,30"
    rsCompras.Update
regAtual = Nz(DLookup("COD_tbl_CadCompras", "tbl_CadCompras", "NUM_PEDIDO = '" & doc.getElementsByTagName("nNF")(0).Text & "'"), 0)
rsCompras.Close
Set rsCompras = Nothing

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

i = 0
cProd = ""
'**********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("COD_tbl_CadProdutos", "tbl_CadProdutos", "COD_PRODUTO = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
    '**********Cadastra o Produto, pois ainda nao foi cadastrado**********
If x <= 0 Then 'If_004
Set rsProdutos = DB.OpenRecordset("tbl_CadProdutos")
xFornecedor = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'X buscará o fornecedor na tabela "tbl_CadFornecedores"
xValorCompra = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",")
xValorVenda = (xValorCompra * 100) / 70
rsProdutos.AddNew
    rsProdutos!COD_PRODUTO = separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>")
    rsProdutos!DESCRICAO_PRODUTO = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
    rsProdutos!DESCRICAO_NFE = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
    rsProdutos!NOME_FORNECEDOR = xFornecedor
    rsProdutos!VALOR_COMPRA = xValorCompra
    rsProdutos!VALOR_VENDA = xValorVenda
    rsProdutos!CFOP = separaEntreDuasStringsXML(cProd, "<CFOP>", "</CFOP>")
    rsProdutos!NCM = separaEntreDuasStringsXML(cProd, "<NCM>", "</NCM>")
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 rsValor = DB.OpenRecordset("select VALOR_COMPRA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
    
    rsValor.Edit
    rsValor("VALOR_COMPRA") = xValorCompra
    rsValor.Update
    rsValor.Close
    
    Set rsValor = DB.OpenRecordset("select VALOR_VENDA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
    
    rsValor.Edit
    rsValor("VALOR_VENDA") = xValorVenda
    rsValor.Update
    rsValor.Close
    
End If 'If_004

x = Nz(DLookup("COD_tbl_CadProdutos", "tbl_CadProdutos", "COD_PRODUTO = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
    '**********Insere o produto cadastrado na Nota de compra**********
Set rsComprasDetalhes = DB.OpenRecordset("tbl_CadComprasDetalhes")
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.Update
rsComprasDetalhes.Close

Set rsComprasDetalhes = Nothing
Set rsProdutos = Nothing
    '**********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!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!fml_CadCompras.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


É claro que, para quem trabalha com isso todos os dias, isso é básico, mas não custa compartilhar.

Grande abraço!!!

Enio Eltz Filho.

Justamente, há a necessidade de Substituir o . por ,.

Bom dia

Segue o código atualizado. Alguém pode ter essa necessidade também.
Incluí o cadastro de tipo de pagamentos. E o registro das faturas a serem pagas na nota de compra.

Enio Eltz Filho.

Código:

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 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)

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 rsFornecedores = DB.OpenRecordset("tbl_CadFornecedores")
x = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'x buscará o fornecedor na tabela "tbl_CadFornecedores"
xCidade = Nz(DLookup("COD_tbl_CadCidades", "tbl_CadCidades", "CIDADE = '" & doc.getElementsByTagName("xMun")(0).Text & "'"), 0) 'x buscará a cidade na tabela "tbl_CadCidades"

If x <= 0 Then 'If_002 Se x for <=0 significa que não está cadastrado, então irá cadastrar o fornecedor
    rsFornecedores.AddNew
        rsFornecedores!NOME_FORNECEDOR = doc.getElementsByTagName("xFant")(0).Text
        rsFornecedores!RAZAO_SOCIAL = doc.getElementsByTagName("xNome")(0).Text
        rsFornecedores!CNPJ = doc.getElementsByTagName("CNPJ")(0).Text
        rsFornecedores!INSCR_EST = doc.getElementsByTagName("IE")(0).Text
        rsFornecedores!END_FORN = doc.getElementsByTagName("xLgr")(0).Text
        rsFornecedores!CIDADE_FORN = xCidade
        rsFornecedores!NUM_END_FORN = doc.getElementsByTagName("nro")(0).Text
        rsFornecedores!ESTADO_FORN = doc.getElementsByTagName("UF")(0).Text
        rsFornecedores!CEP_FORN = doc.getElementsByTagName("CEP")(0).Text
        rsFornecedores!TELEFONE = doc.getElementsByTagName("fone")(0).Text
    rsFornecedores.Update

x = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'Apos cadastrar o fornecedor, x buscara o ID desse fornecedor para ser utilizado na importação do xml em questao
rsFornecedores.Close
Set rsFornecedores = 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("tbl_CadCompras")
rsCompras.AddNew
    rsCompras!CHAVE_TBL = "CO"
    rsCompras!NUM_PEDIDO = 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!DATA_PEDIDO = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
    Else
    rsCompras!DATA_PEDIDO = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
    End If 'If_004
    rsCompras!FORNECEDOR = x
    rsCompras!DATA_1A_PARCELA = doc.getElementsByTagName("dVenc")(0).Text
    rsCompras!TIPO_PGTO = xTipo
    rsCompras!VALOR_BOLETO = Replace(separaEntreDuasStringsXML(cICMSTot, "<vOutro>", "</vOutro>"), ".", ",")
    rsCompras!VALOR_TOT_NFE = Replace(doc.getElementsByTagName("vOrig")(0).Text, ".", ",")
    rsCompras.Update
regAtual = Nz(DLookup("COD_tbl_CadCompras", "tbl_CadCompras", "NUM_PEDIDO = '" & 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("COD_tbl_CadProdutos", "tbl_CadProdutos", "COD_PRODUTO = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)

    '**********Cadastra o Produto, pois ainda nao foi cadastrado**********
If x <= 0 Then 'If_005
Set rsProdutos = DB.OpenRecordset("tbl_CadProdutos")
xFornecedor = Nz(DLookup("COD_tbl_CadFornecedores", "tbl_CadFornecedores", "CNPJ = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'X buscará o fornecedor na tabela "tbl_CadFornecedores"
xValorCompra = Replace(separaEntreDuasStringsXML(cProd, "<vUnCom>", "</vUnCom>"), ".", ",")
xValorVenda = (xValorCompra * 100) / 70
rsProdutos.AddNew
    rsProdutos!COD_PRODUTO = separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>")
    rsProdutos!DESCRICAO_PRODUTO = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
    rsProdutos!DESCRICAO_NFE = separaEntreDuasStringsXML(cProd, "<xProd>", "</xProd>")
    rsProdutos!NOME_FORNECEDOR = xFornecedor
    rsProdutos!VALOR_COMPRA = xValorCompra
    rsProdutos!VALOR_VENDA = xValorVenda
    rsProdutos!CFOP = separaEntreDuasStringsXML(cProd, "<CFOP>", "</CFOP>")
    rsProdutos!NCM = separaEntreDuasStringsXML(cProd, "<NCM>", "</NCM>")
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 rsValor = DB.OpenRecordset("select VALOR_COMPRA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
    
    rsValor.Edit
    rsValor("VALOR_COMPRA") = xValorCompra
    rsValor.Update
    rsValor.Close
    
    Set rsValor = DB.OpenRecordset("select VALOR_VENDA, COD_tbl_CadProdutos from tbl_CadProdutos where COD_tbl_CadProdutos = " & x & "")
    
    rsValor.Edit
    rsValor("VALOR_VENDA") = xValorVenda
    rsValor.Update
    rsValor.Close
    
End If 'If_005

x = Nz(DLookup("COD_tbl_CadProdutos", "tbl_CadProdutos", "COD_PRODUTO = '" & separaEntreDuasStringsXML(cProd, "<cProd>", "</cProd>") & "'"), 0)
    '**********Insere o produto cadastrado na Nota de compra**********
Set rsComprasDetalhes = DB.OpenRecordset("tbl_CadComprasDetalhes")
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.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!fml_CadCompras.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