Importar todas as NFe (Nota Fiscal Eletrônica (Xml)) de uma pasta (versão Xml: 1.10, 2.00 e 3.10)

Nesse exemplo o sistema realiza o lançamento automático das Notas Fiscais Eletrônica Brasileira. Bastando o usuário informar onde está a Pasta com os arquivos Xml. É realizado o desmembramento dos dados em 4 tabelas (tbCadProd, tbFornecedores, tbCompras e tbComprasDet)
O método utilizado é o de Leitura do arquivo XML combinado com a função separaEntreDuasStringsXML do Ahteixeira.

O que o sistema faz:

1. Lança todas as NFe de uma pasta
´  1.1 Verifica se o Fornecedor está cadastrado:
´     1.1.1 Se não tiver, realiza o Cadastramento
´     1.1.2 Se Tiver, apenas busca o Código para lançar a Compra

´  1.2 Verifica se o Produto está cadastrado:
´     1.2.1 Se não tiver, realiza o Cadastramento e lança o Estoque
´     1.2.2 Se Tiver, busca o Código para lançar na compra e atualiza o Estoque

Com pequenos comando do usuário final, é possível lançar a compra, cadastrar o Fornecedor e Cadastrar os Produtos.


Testes realizados:
Importação de 6.038 arquivos .xml.
Importação local, realizada com uma máquina Pentium 4:
Importado 6.007 NFe, Cadastrado 4.031 Produtos e Ignorado 31 Xml com erro
Tempo gasto: 4min31seg


Em Anexo na pasta XML tem 5 arquivos, sendo que 1 contém erro.
Ao realizar a importação deverá conter:
38 Produtos, 4 Notas de compra e 3 Fornecedores.
Extrutura de um XML


Obs: Se for detectado Erros ou houver sugestão de melhorias por favor voltar a este Tópico e reportar, assim todos termos o melhor!
Caso acuse erro 13, a variável não foi definida deve verificar se a TAG XML buscada foi encontrada, ou se o arquivo e um xml válido.
Se atentar para as referências, caso moca o projeto para seu aplicativo.



Modulo de Importaçã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 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, "<vProd>", "</vProd>"), ".", ",")
        'Valor Liquido "Valor Bruto-descontos"
        rsCompra!ValorNFL = Replace(separaEntreDuasStringsXML(xProd, "<vNF>", "</vNF>"), ".", ",")
    
    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, "<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!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


Função separaEntreDuasStringsXML:

Código:

Function separaEntreDuasStringsXML(strTotal As String, strInicio As String, strFim As String)
'                 2014 Alvaro Teixeira                          '
'                Adaptado por Fabio Paes                        '
'           Em 12/02/2017 para MAXIMOACCESS                     '

Dim strP As String
On Error Resume Next
Dim i As Long, j As Long
i = InStr(strTotal, strInicio)
    'Aqui ele separa o Texto para determinar o Fim da Extração.
    strP = Mid(strTotal, i + (Len(strInicio)), Len(strTotal))
    j = InStr(strP, strFim)
    separaEntreDuasStringsXML = Mid(strTotal, i + Len(strInicio), j - 1)
    If Nz(Len(separaEntreDuasStringsXML), 0) = 0 Then
        separaEntreDuasStringsXML = 0
    End If
End Function

Tópicos Relacionados:
https://www.maximoaccess.com/t29830-resolvidoerro-ao-importar-xml
https://www.maximoaccess.com/t29919-resolvidoimportar-dados-do-destinatario-da-nf-e-xml#207920

Excelente Exemplo FabioPaes.

Fantástico, parabéns!

Caso queiram que após a importação, o formulário mova para a Ultima NF importada:

No Modulo, comente o Requery que tem la, ele fica antes da Mensagbox.

Agora no Botão de importação, que chama o Modulo coloque assim: (adapte para seus Formulários)

Private Sub btImportar_Click()
Call ImportaXML(Me.txtLocalXML)
Forms!frmCompras.SetFocus
Me.Requery
DoCmd.GoToRecord , , acLast
End Sub

valeu .. dá gosto de ver esses trabalhos em access . obrigado

Boa tarde Fabio Paes

Baixei o seu exemplo, obrigado por compartilhar, muito bom!!!

abraço

Parabéns! Ficou muito bom, tava procurando isso já algum tempo.

Opa,
Muito bom.

Vou baixar !
Que aprendizado !

Muito bom trabalho.

Parabéns Fábio! Muito bom!!

Como sugestão...

Fiz algo menos avançado do que o seu alguns anos, me utilizei do VBA no Outlook para administras os e-mails recebidos. O proprio Outlook fazia o recebimento do e-mail, separava em pastas distintas os anexos XML, PDF e Outros tipos além da inserção do banco de dados. Muitas empresas hoje optam pelo automatismo no processo, veja se essa ideia não lhe dá um norte para a implementação de mais funções na sua rotina...