[Resolvido]Importar Xml Lote "Importar Duplicata"

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

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:




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:

obrigado FabioPaes

como que busco  nesta xml  onde  tem o 799

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.