[Resolvido]Importar dados do destinatário da NF-e xml

Boa tarde

Estou precisando de auxilio
Preciso importar os dados do destinatário da NF-e de saida
Estou usando o código do Fabio Paes.
Nas notas de entrada dá tudo certo
Nas de saída os dados importados são os do emitente
Uso o frmsaida para importar as saidas
 
[code]Option Compare Database
Public Function ImportaXMLsaida(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, rsCli, R50_S, R54_S As DAO.Recordset
Dim xProd As String
Dim dest As Object
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 xDest = doc.getElementsByTagName("dest")
'------------------------------------------------------------------------'
'Insere os Dados do Cliente, se nao for Cadastrado.
For Each dest In xDest
Set rsCli = DB.OpenRecordset("tbClientes")
x = Nz(DLookup("IdFor", "tbClientes", "Cnpj = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0) 'X buscará o cliente na tabela "tbClientes"
If x <= 0 Then 'Se x for <=0 significa que nao ta cadastrado, entao irá cadastrar o cliente
   rsCli.AddNew
       rsCli!NomeForn = doc.getElementsByTagName("xNome")(0).Text
       rsCli!CNPJ = separaEntreDuasStringsXML("dest", "<CNPJ>", "</CNPJ>")
   rsCli.Update
'Apos cadastrar o cliente, x buscara o ID desse fcliente para ser utilizado na importação do xml em questao
x = Nz(DLookup("IdFor", "tbClientes", "Cnpj = '" & doc.getElementsByTagName("CNPJ")(0).Text & "'"), 0)
rsCli.Close
Set rsClir = Nothing
End If[
'------------------------------------------------------------------------'
'Dados Principais da Nota de Compra (R50_S)
Set rsR50_S = DB.OpenRecordset("R50_S")
rsR50_S.AddNew
   rsR50_S!IdFornecedor = x
   rsR50_S!CGC = separaEntreDuasStringsXML("xdest", "<CNPJ>", "</CNPJ>")
   rsR50_S!IE = separaEntreDuasStringsXML("xdest", "<IE>", "</IE>")
   '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
   rsR50_S!EMISSAO = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
   Else
   rsR50_S!EMISSAO = 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
       rsR50_S!VALORTOTAL = Replace(separaEntreDuasStringsXML(xProd, "<vProd>", "</vProd>"), ".", ",")
       'Valor Liquido "Valor Bruto-descontos"
       rsR50_S!xVALORTOTAL = Replace(separaEntreDuasStringsXML(xProd, "<vNF>", "</vNF>"), ".", ",")
               'Imposto = doc.getElementsByTagName("total")(0).XML
       'Valor BC
       'rsR50_S!BASEICMS = Replace(separaEntreDuasStringsXML(Imposto, "<vBC>", "</vBC>"), ".", ",")
       'Valor ICMS retido
       'rsR50_S!VALORICMS = Replace(separaEntreDuasStringsXML(Imposto, "<vICMS>", "</vICMS>"), ".", ",")
   rsR50_S!MODELO = doc.getElementsByTagName("mod")(0).Text
   rsR50_S!SERIE = doc.getElementsByTagName("serie")(0).Text
   rsR50_S!NUMERO = doc.getElementsByTagName("nNF")(0).Text
   rsR50_S!CFOP = doc.getElementsByTagName("CFOP")(0).Text
   rsR50_S!MODELO = doc.getElementsByTagName("mod")(0).Text
   rsR50_S!SERIE = doc.getElementsByTagName("serie")(0).Text
   rsR50_S!UF = doc.getElementsByTagName("UF")(0).Text
   rsR50_S!ALIQUOTA = Replace(separaEntreDuasStringsXML(xProd, "<pICMS>", "</pICMS>"), ".", ",")
   rsR50_S!ChaveNF = doc.getElementsByTagName("chNFe")(0).Text
   
rsR50_S.Update
regAtual = Nz(DLookup("ID", "R50_S", "ChaveNF = '" & doc.getElementsByTagName("chNFe")(0).Text & "'"), 0)

rsR50_S.Close
Set rsR50_S = 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, "<xProd>", "</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, "<xProd>", "</xProd>")
   rsProd!Unid = separaEntreDuasStringsXML(xProd, "<uCom>", "</uCom>")
   rsProd!CODCONTRIB = doc.getElementsByTagName("cProd")(0).Text
rsProd.Update
x = Nz(DLookup("IdProd", "tbCadProd", "DescProd = '" & separaEntreDuasStringsXML(xProd, "<xProd>", "</xProd>") & "'"), 0)
'Insere o produto cadastrado na Nota de compra
Set rsR54_S = DB.OpenRecordset("R54_S")
rsR54_S.AddNew
   rsR54_S!IDCompra = regAtual
   rsR54_S!IDProd = x
   rsR54_S!QTDE = Replace(separaEntreDuasStringsXML(xProd, "<qCom>", "</qCom>"), ".", ",")
   'rsR54_S!ValorUnit = Replace(separaEntreDuasStringsXML(xProd, "<vUnCom>", "</vUnCom>"), ".", ",")
   rsR54_S!VALORPRODUTO = Replace(separaEntreDuasStringsXML(xProd, "<vUnCom>", "</vUnCom>"), ".", ",") * Replace(separaEntreDuasStringsXML(xProd, "<qCom>", "</qCom>"), ".", ",")
   rsR54_S!ALIQICMS = Replace(separaEntreDuasStringsXML(xProd, "<pICMS>", "</pICMS>"), ".", ",")
   rsR54_S!CGC = doc.getElementsByTagName("CNPJ")(0).Text
   rsR54_S!NUMERO = doc.getElementsByTagName("nNF")(0).Text
   rsR54_S!MODELO = doc.getElementsByTagName("mod")(0).Text
   rsR54_S!SERIE = doc.getElementsByTagName("serie")(0).Text
   rsR54_S!CFOP = doc.getElementsByTagName("CFOP")(0).Text
   rsR54_S!CST = doc.getElementsByTagName("CST")(0).Text
   rsR54_S!DescProd = separaEntreDuasStringsXML(xProd, "<xProd>", "</xProd>")
   If rsR54_S!CST = 60 Then
   rsR54_S!BCICMSSUBS = Replace(separaEntreDuasStringsXML(xProd, "<vBCSTRet>", "</vBCSTRet>"), ".", ",")
   Else
   rsR54_S!BCICMSSUBS = Replace(separaEntreDuasStringsXML(xProd, "<vBCST>", "</vBCST>"), ".", ",")
   End If
   If (doc.getElementsByTagName("dhEmi").length) Then
   rsR54_S!Data = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
   Else
   rsR54_S!Data = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
   End If
rsR54_S.Update

rsR54_S.Close
rsProd.Close
Set rsR54_S = 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, "<qCom>", "</qCom>"), ".", ",")
'rsProd.Update
'Insere o produto que ja estava cadastrado na Nota de compra
Set rsR54_S = DB.OpenRecordset("R54_S")
rsR54_S.AddNew
   rsR54_S!IDCompra = regAtual
   rsR54_S!IDProd = x
   rsR54_S!QTDE = Replace(separaEntreDuasStringsXML(xProd, "<qCom>", "</qCom>"), ".", ",")
   rsR54_S!CODCONTRIB = doc.getElementsByTagName("cProd")(0).Text
   rsR54_S!VALORPRODUTO = Replace(separaEntreDuasStringsXML(xProd, "<vUnCom>", "</vUnCom>"), ".", ",") * Replace(separaEntreDuasStringsXML(xProd, "<qCom>", "</qCom>"), ".", ",")
   rsR54_S!ALIQICMS = Replace(separaEntreDuasStringsXML(xProd, "<pICMS>", "</pICMS>"), ".", ",")
   rsR54_S!CGC = doc.getElementsByTagName("CNPJ")(0).Text
   rsR54_S!NUMERO = doc.getElementsByTagName("nNF")(0).Text
   rsR54_S!MODELO = doc.getElementsByTagName("mod")(0).Text
   rsR54_S!SERIE = doc.getElementsByTagName("serie")(0).Text
   rsR54_S!CFOP = doc.getElementsByTagName("CFOP")(0).Text
   rsR54_S!CST = doc.getElementsByTagName("CST")(0).Text
   rsR54_S!DescProd = separaEntreDuasStringsXML(xProd, "<xProd>", "</xProd>")
   If rsR54_S!CST = 60 Then
   rsR54_S!BCICMSSUBS = Replace(separaEntreDuasStringsXML(xProd, "<vBCSTRet>", "</vBCSTRet>"), ".", ",")
   Else
   rsR54_S!BCICMSSUBS = Replace(separaEntreDuasStringsXML(xProd, "<vBCST>", "</vBCST>"), ".", ",")
   End If
   If (doc.getElementsByTagName("dhEmi").length) Then
   rsR54_S!Data = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
   Else
   rsR54_S!Data = Format(doc.getElementsByTagName("dEmi")(0).Text, "dd/mm/yyyy")
   End If
rsR54_S.Update
'Limpa os dados do recordset e fecha a conecção
rsR54_S.Close
rsProd.Close
Set rsR54_S = 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!frmSaidas.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
/code]


Grato

Certo amigo, e qual o Problema encontrado?

Caro Fabio, quando faço a importação dos dados das NF de saida só importa os dados do emitente no lugar do destinatário - CNPJ, IE, Nome

Observe as instruções da Imagem a baixo que entenderá!

Fabio, está dando um erro de compilação "for sem next", marca o EndSub

Fabio
Problemas resolvidos
Muito obrigado

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

Boa noite Fabio Paes, sou novo aqui no forum, gostei muito do seu exemplo de importar os dados da NF-e, só já quebrei a cabeça e não consegui ajustar para que importe tambem os dados das faturas, vê se quebra essa bronca aí se possivel de forma mais detalhada, grato