MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Importar CTe

    elpauli
    elpauli
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 19
    Registrado : 10/08/2016

    Importar CTe Empty Importar CTe

    Mensagem  elpauli em Qua 5 Abr - 4:28

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

    Importar CTe Cte
    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
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6957
    Registrado : 15/03/2013

    Importar CTe Empty Re: Importar CTe

    Mensagem  ahteixeira em Qua 5 Abr - 7:19

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

      Data/hora atual: Qui 3 Dez - 9:45