[Resolvido]Importar cupom fiscal sat xml

Bom dia

Agora preciso importar os dados do cupom fiscal no access

Tentei usar o código de importação da NFe do FabioPaes, mas não importa nenhum dado.

Está dando erro de validação em todos os xml

Segue o código

Código:


Option Compare Database
Public Function ImportaXMLSaidaEcf(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, rsR60I 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("URI").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!IE = doc.getElementsByTagName("IE")(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 rsR60I = DB.OpenRecordset("R60I")
rsR60I.AddNew
    rsR60I!IDCompra = regAtual
    rsR60I!IDProd = 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
    rsR60I!xdata = Format(Left(doc.getElementsByTagName("dhEmi")(0).Text, 10), "dd/mm/yyyy")
    Else
    rsR60I!xdata = 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
        rsR60I!ValorProduto = Replace(separaEntreDuasStringsXML(xProd, "<vProd>", "</vProd>"), ".", ",")
        'Valor Liquido "Valor Bruto-descontos"
        rsR60I!valortotal = Replace(separaEntreDuasStringsXML(xProd, "<vCFe>", "</vCFe>"), ".", ",")
    rsR60I!CODCONTRIB = doc.getElementsByTagName("cProd")(0).Text
    rsR60I!NUMDOCUM = doc.getElementsByTagName("nCFe")(0).Text
    rsR60I!ChaveNF = doc.getElementsByTagName("URI")(0).Text
rsR60I.Update
regAtual = Nz(DLookup("ID", "rsR60I", "ChaveNF = '" & doc.getElementsByTagName("URI")(0).Text & "'"), 0)

rsR60I.Close
Set rsR60I = 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!Estoque = Replace(separaEntreDuasStringsXML(xProd, "<qCom>", "</qCom>"), ".", ",")
rsProd.Update
x = Nz(DLookup("IdProd", "tbCadProd", "DescProd = '" & separaEntreDuasStringsXML(xProd, "<xProd>", "</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, "<qCom>", "</qCom>"), ".", ",")
    'rsCompDet!ValorUnit = Replace(separaEntreDuasStringsXML(xProd, "<vUnCom>", "</vUnCom>"), ".", ",")
    'rsCompDet!ValorTot = Replace(separaEntreDuasStringsXML(xProd, "<vUnCom>", "</vUnCom>"), ".", ",") * Replace(separaEntreDuasStringsXML(xProd, "<qCom>", "</qCom>"), ".", ",")
    'rsCompDet!ICMS = Replace(separaEntreDuasStringsXML(xProd, "<pICMS>", "</pICMS>"), ".", ",")
'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, "<qCom>", "</qCom>"), ".", ",")
'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, "<qCom>", "</qCom>"), ".", ",") 'O replace e utilizado para substituir o . por ,
    'rsCompDet!ValorUnit = Replace(separaEntreDuasStringsXML(xProd, "<vUnCom>", "</vUnCom>"), ".", ",")
    'rsCompDet!ValorTot = Replace(separaEntreDuasStringsXML(xProd, "<vUnCom>", "</vUnCom>"), ".", ",") * Replace(separaEntreDuasStringsXML(xProd, "<qCom>", "</qCom>"), ".", ",")
    'rsCompDet!ICMS = Nz(Replace(separaEntreDuasStringsXML(xProd, "<pICMS>", "</pICMS>"), ".", ","), 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!frmSaidasEcf.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


Espero que alguém consiga me ajudar
Grato
Elias