Importar CTe

Este exemplo em VBA faz a Leitura de um XML de CTe e Importa para seu Registro de Compras.


Option Compare Database
Option Explicit
Dim sArquivo As String, lngIdFornecedor As Long, flagCadastro As Integer
Dim sCst As String, sBase As Currency, sVlrIcms As Currency, sAliquota As Single
Dim dbs As DAO.Database

Private Sub cmdImportar_Click()
On Error Resume Next
'//LOCALIZAR O ARQUIVO DO CTE
       sArquivo = PegaPathXml("H:\ARQUIVOS_SIGA\XML_FORNECEDORES", "Arquivos XML", "*.XML")
       If Len(sArquivo) > 0 Then
           Shd1 = Left(Shd1, InStr(Shd1, vbNullChar) - 1)
           Me.txtPath = sArquivo
           Me.txtPath.SetFocus
           Call cmdImportaXml
       End If
End Sub
Private Sub cmdImportaXml()
On Error GoTo Er_get
'********************************************************************
'//ROTINA PARA IMPORTAR O CTE PARA O REGISTRO DE COMPRAS
'//DESENVOLVIDO POR ELCIO LUIZ PAULI
'//CUIABÁ - MT ABRIL / 2017
'//CORTESIA AO FORUM
'///elpauli@hotmail.com
'********************************************************************
Dim lngIdCompras As Long, iTomador As Integer, NfeFrete  As String
Dim cValorCte As Currency, sCnpj As String, PathDestino As String, sMesAno As String, iCfop As String, nCfop As String
Dim iEmpresa As Integer, CnpjDest As String, sDataEmi As String, lngCte As Long, sSerie As String, rsEmpresa As DAO.Recordset
'//DEFINIÇÕES DAS VARIAVEIS
   Dim sChave As String
   Dim objDOC As DOMDocument
   Dim objNodeList As IXMLDOMNodeList
   Dim dbs As DAO.Database, strSql As String
   Dim objNodeForn As IXMLDOMNode
   Dim wrk As DAO.Workspace
   Set wrk = DBEngine.Workspaces(0)
   Set objDOC = New DOMDocument
   Set dbs = Application.CurrentDb
   '//ABRIR O REGISTRO DAS EMPRESAS CADASTRADAS NO SIGA
   Set rsEmpresa = dbs.OpenRecordset("SELECT LICENCIADO.IDLicenciado, LICENCIADO.LIC_CGC FROM LICENCIADO;")
   objDOC.Load (sArquivo) ' CarregO XML do CTE
   cValorCte = 0
   flagCadastro = 0
   '//pega a data de emissão do CTe
   Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/ide/dhEmi")
   sDataEmi = objNodeList.Item(0).Text
   '//definir o tomador do Serviço antes de capturar os dados.
   Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/ide/toma03/toma")
   iTomador = objNodeList.Item(0).Text
   '//pega o valor do Cte
   Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/vPrest/vTPrest")
   cValorCte = Replace(objNodeList.Item(0).Text, ".", ",")
   '//Verificar conforme se a Empresa é tomadora do Serviço
   '0-Remetente; 
   '1-Expedidor; 
   '2-Recebedor; 
   '3-Destinatário 
   Select Case iTomador
       Case 0
           Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/rem/CNPJ")
           CnpjDest = objNodeList.Item(0).Text
       Case 1
           Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/exped/CNPJ")
           CnpjDest = objNodeList.Item(0).Text
       Case 2
           Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/receb/CNPJ")
           CnpjDest = objNodeList.Item(0).Text
       Case Else
           Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/dest/CNPJ")
           CnpjDest = objNodeList.Item(0).Text
   End Select
   '//Pega a Chave
   Set objNodeList = objDOC.selectNodes("cteProc/protCTe/infProt/chCTe")
   sChave = objNodeList.Item(0).Text
       
   '//pegar a Nfe do Frete
   Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/infCTeNorm/infDoc/infNFe/chave")
   NfeFrete = objNodeList.Item(0).Text
'//DADOS DA EMISSAO DO CTE
   sDataEmi = Left(sDataEmi, 10)
   sDataEmi = Format(sDataEmi, "dd/mm/yyyy")
   lngCte = CLng(Mid(sChave, 26, 9))
   sSerie = Mid(sChave, 23, 3)
   '//GRAVA O CNPJ DO EMITENTE
   sCnpj = Mid(sChave, 7, 14)
'//LOCALIZAR CADASTRO SE HOUVER
   lngIdFornecedor = Nz(DLookup("[FR_COD]", "FORNECEDORES", "[FR_CGC_CPF]='" & sCnpj & "'"), 0)
   If lngIdFornecedor = 0 Then
       flagCadastro = 1
       Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/emit")
       Set objNodeForn = objNodeList.nextNode
       Call CadastrarFornecedor(objNodeForn)
   Else
       flagCadastro = 0
   End If
   If flagCadastro = 1 Then
       Set objDOC = Nothing
       Set objNodeList = Nothing
       Set dbs = Nothing
       Set wrk = Nothing
       Exit Sub
       MsgBox "Erro ao Cadastrar o Fornecedor!", vbCritical, strApp
       Exit Sub
   End If
   '//Capturar impostos do CTE
   Set objNodeList = objDOC.selectNodes("cteProc/CTe/infCte/imp/ICMS")
   Set objNodeForn = objNodeList.nextNode
   Call PegaImpostos(objNodeForn)
   Set objDOC = Nothing
   Set objNodeList = Nothing
'//VALIDAR O CNPJ DO DESTINATARIO OU PAGADOR DO FRETE    
   rsEmpresa.FindFirst "LIC_CGC ='" & CnpjDest & "'"
   If rsEmpresa.NoMatch Then
       iEmpresa = 0
   Else
       iEmpresa = rsEmpresa("IDLicenciado")
   End If
   If iEmpresa = 0 Then
       rsEmpresa.Close
       Set rsEmpresa = Nothing
       MsgBox "A Empresa Destinatária/Responsável do CTe não existe como Licenciada!", vbCritical, strApp
       Exit Sub
   End If
   rsEmpresa.Close
   Set rsEmpresa = Nothing
   sMesAno = Format(Date, "mmyyyy")
'//DEFINIR O CFOP DE ENTRADA
   If Left(sChave, 2) = "51" Then
       iCfop = "1353"
       nCfop = "5353"
   Else
       iCfop = "2353"
       nCfop = "6353"
   End If
   PathDestino = "H:\ARQUIVOS_SIGA\XML_FORNECEDORES\" & CnpjDest & "\" & sMesAno
   '//CRIAR A PASTA CASO NAO EXISTA
   Call CriarPasta(PathDestino)
   PathDestino = "H:\ARQUIVOS_SIGA\XML_FORNECEDORES\" & CnpjDest & "\" & sMesAno & "\" & Shd1
'//GERAR OS DADOS PARA A TABELA DE COMPRAS
   lngIdCompras = Nz(DMax("[IDCOMPRAS]", "COMPRAS"), 0) + 1
   strSql = "INSERT INTO COMPRAS ( IDCOMPRAS, CPR_DATA, DT_EMIS, FR_COD, CPR_NF, CPR_SERIE, CPR_TOTAL," & _
   " CPR_CODMOD, CPR_NFECHAVE, CPR_REGISTRO," & _
   " CPR_TOTALITENS, CPR_DTSAIDA, CPR_CCUSTO, CPR_XML, DTSAVE, IDUSER, CPR_EMPRESA, CPR_CFOP, CPR_OBS, CPR_BASEICMS, CPR_ICMS, GERA_ESTOQUE )" & _
   " SELECT " & lngIdCompras & ",#" & Format(Date, "mm/dd/yyyy") & "#,#" & sDataEmi & "#," & lngIdFornecedor & "," & lngCte & ",'" & sSerie & "','" & cValorCte & _
   "',57,'" & sChave & "','D100','" & cValorCte & "',#" & Format(Date, "mm/dd/yyyy") & "#,18,'" & PathDestino & "', Now(),'" & UserAtual & "'," & iEmpresa & ",'" & nCfop & "','" & _
   "REFERENTE FRETE DA NF: " & NfeFrete & "','" & sBase & "','" & sVlrIcms & "',0"
   dbs.Execute (strSql)
'//GERAR DADOS PARA A TABELA DE ITENS DA COMPRA
   strSql = "INSERT INTO SUB_COMPRAS ( IDCOMPRAS, IDPRODUTO, PRODUTO, P_CFOP, QUANTIDADE, UNITARIO," & _
       " QT_ESTOQUE, UNIT_ESTOQUE, S_VPROD, P_TOTAL, P_CST, S_ALIQUOTA, P_BASEICMS, P_ICMS, E_CST )" & _
       " SELECT " & lngIdCompras & ",2,'FRETE SOBRE COMPRAS','" & iCfop & "',1,'" & cValorCte & "',1,'" & cValorCte & "','" & cValorCte & "','" & cValorCte & "','" & _
       sCst & "','" & sAliquota & "','" & sBase & "','" & sVlrIcms & "','" & sCst & "'"
   dbs.Execute (strSql)

   Set dbs = Nothing
   Set wrk = Nothing
'//COPIAR O XML PARA A PASTA DO SISTEMA
   Call MoverDocCli(sArquivo, PathDestino)
   If flagCadastro = 2 Then
       MsgBox "O Fornecedor não estava Cadastrado." & _
           vbCrLf & vbCrLf & "Algumas informações podem requerer sua Atenção!", vbOKOnly, strApp
   End If
'//ABRIR O REGISTRO DA COMPRA COM OS DADOS DO CTE PARA FINALIZACAO
   DoCmd.OpenForm "F_COMPRAS_ADM", acNormal, , "[IDCOMPRAS]=" & lngIdCompras, acFormEdit
   DoCmd.Close acForm, Me.Name
   Shd1 = ""
exit_get:

   Exit Sub
Er_get:
   If Err.Number = 91 Then
       MsgBox "Erro na leitura de um Arquivo Inexistente! " & _
       vbCrLf & vbCrLf & "Erro: " & Err.Number & _
       vbCrLf & vbCrLf & Err.Description & _
       vbCrLf & "Avise suporte.", vbCritical, "Erro em GetXml"
   Else
       MsgBox "Erro na leitura do Arquivo: " & sArquivo & _
       vbCrLf & vbCrLf & "Erro: " & Err.Number & _
       vbCrLf & vbCrLf & Err.Description & _
       vbCrLf & "Avise suporte.", vbCritical, "Erro em GetXml"
   End If
   Resume exit_get
End Sub

Private Sub MoverDocCli(wOrigem As String, wDestino As String)
On Error Resume Next
'//COPIAR OS ARQUIVOS PARA AS PASTAS DO SISTEMA
   CopyFile wOrigem, wDestino, True
   Kill wOrigem
End Sub

Private Sub CriarPasta(sPasta)
On Error Resume Next
'//CRIAR AS PASTAS CASO NÃO EXISTAM
Dim fso, fldr
Set fso = CreateObject("Scripting.FileSystemObject")

   Set fldr = fso.GetFolder(sPasta)
   If Err.Number = 76 Then
       Set fldr = fso.CreateFolder(sPasta)
   End If
   
Set fldr = Nothing
Set fso = Nothing


End Sub

Private Sub CadastrarFornecedor(oChild0 As IXMLDOMElement)
'//CADASTRAR O FORNECEDOR SE ESTE NÃO EXISTIR
On Error Resume Next
   Dim oChild1 As IXMLDOMElement
   Dim oChild4 As IXMLDOMNode
   Dim dbForn As DAO.Database, wrk As Workspace
   Dim rs As DAO.Recordset
   Set wrk = DBEngine.Workspaces(0)
   Set dbForn = Application.CurrentDb
   lngIdFornecedor = DMax("[ID_NEWCOD]", "ID_TDFS") + 1
   Set rs = dbForn.OpenRecordset("FORNECEDORES")
   With rs
       .AddNew
       ![FR_COD] = lngIdFornecedor
       ![FR_SEGMENTO] = 1
       ![FR_DTCAD] = Date
       For Each oChild1 In oChild0.childNodes
           If UCase(oChild1.nodeName) = "ENDEREMIT" Then
               For Each oChild4 In oChild1.childNodes
                   If UCase(oChild4.nodeName) = "XLGR" Then
                       ![FR_ENDEREÇO] = UCase(oChild4.Text)
                   ElseIf UCase(oChild4.nodeName) = "NRO" Then
                       ![FR_NRLOG] = oChild4.Text
                   ElseIf UCase(oChild4.nodeName) = "XBAIRRO" Then
                       ![FR_BAIRRO] = UCase(oChild4.Text)
                   ElseIf UCase(oChild4.nodeName) = "CMUN" Then
                       ![FR_CODMUM] = oChild4.Text
                   ElseIf UCase(oChild4.nodeName) = "XMUN" Then
                       ![FR_CIDADE] = UCase(oChild4.Text)
                   ElseIf UCase(oChild4.nodeName) = "UF" Then
                       ![FR_ESTADO] = UCase(oChild4.Text)
                   ElseIf UCase(oChild4.nodeName) = "CEP" Then
                       ![FR_CEP] = oChild4.Text
                   ElseIf UCase(oChild4.nodeName) = "FONE" Then
                       ![FR_FONE] = oChild4.Text
                   End If
               Next
           Else
               If UCase(oChild1.nodeName) = "XNOME" Then
                   ![FR_RAZAO] = UCase(oChild1.Text)
               End If
               If UCase(oChild1.nodeName) = "IE" Then
                   ![FR_INS] = oChild1.Text
               End If
               If UCase(oChild1.nodeName) = "CNPJ" Then
                   ![FR_CGC_CPF] = oChild1.Text
               End If
           End If
       Next
   End With
   dbForn.Execute ("UPDATE ID_TDFS SET ID_TDFS.ID_NEWCOD = ID_TDFS.ID_NEWCOD + 1;")
   rs.Update
   rs.Close
   Set dbForn = Nothing
   Set wrk = Nothing
   flagCadastro = 2
End Sub

Private Sub PegaImpostos(oChild0 As IXMLDOMElement)
On Error Resume Next
'//GRAVAR INFORMAÇÕES FISCAIS RELACIONADAS NO CTE
   Dim oChild1 As IXMLDOMElement
   Dim oChild4 As IXMLDOMNode
       For Each oChild1 In oChild0.childNodes
           If Left(oChild1.nodeName, 4) = "ICMS" Then
               For Each oChild4 In oChild1.childNodes
                   If oChild4.nodeName = "CST" Then
                       sCst = "0" & oChild4.Text
                   ElseIf oChild4.nodeName = "vBC" Then
                       sBase = Replace(oChild4.Text, ".", ",")
                   ElseIf oChild4.nodeName = "pICMS" Then
                       sAliquota = Replace(oChild4.Text, ".", ",")
                   ElseIf oChild4.nodeName = "vICMS" Then
                       sVlrIcms = Replace(oChild4.Text, ".", ",")
                   End If
               Next
           End If
       Next
End Sub

O Código todo está ajustado no form conforme imagem anexa.

Se melhorias, serão bem vindas para correção.

Bons estudos.

Abraços

Elcio Pauli

Olá Elcio Pauli,obrigado pela partilha.
Abraço