[Resolvido]Importação XML de guias.

ahteixeira, boa tarde,

Segue exemplo semelhante ao que fiz na mensagem 39. Link abaixo.

Como o XML que gerou o problema é do tipo guiaSP-SADT, eu achei um tanto estranho o código não importar os dados do ficheiro na integra.

Ficheiro: ENVIO_LOTE_GUIAS_doc_40774_id_26185

Link: https://www.dropbox.com/s/07sbdltodqnv4fw/extrairCampoXml_registo_v3.rar?dl=0

Olá Gomes, veja agora, foi só alterar como o outro "tipo" de ficheiro.

Código:

             'Inicio - guiaSP-SADT
              'If InStr(txtLinha, "</ans:guiaSP-SADT>") > 0 And Importar = 1 Then
               If InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 1 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 1 Then


Abraço

extrairCampoXml_registo_v3.zip

Prezado,

Baixei o exemplo.

No ficheiro ENVIO_LOTE_GUIAS_doc_40774_id_26185 o código não está importando as informações abaixo, ou seja, os dados importados não estão condizentes com os registros do ficheiro, falta informações a serem importadas.

Codigo Descrição Valor
60023112 - TAXA DE SALA CIRURGICA, PORTE ANESTESICO 2 - 664,23
60022973 - TAXA DE SALA CIRURGICA, ATE 1 HORA - 221,41

A tabela com todos os registros ficaria assim.

https://www.dropbox.com/s/8iguwc6q18uycsr/Doc1.docx?dl=0

Ola de momento estou no telemóvel, não será ajustar conforme o outro tipo de ficheiro.
Através da identificação do no do tipo de movimento (60023112).
Depois dou uma vista de olhos.
Abraço

Olá, veja se está como pretendido.
Abraço

extrairCampoXml_registo_v4.zip

Olá,

Agradeço a disponibilidade.

Vou analisar as informações e retorno...

Olá,

Estou a analisar o código e não tive sucesso na importação do ficheiro XML, os dados não estão condizentes com o arquivo.

Quando eu tento importar uns 180 ficheiros para tabela o código não está distinguindo o que é guiaSP-SADT e guiaResumoInternacao.

Vou analisar mais a fundo e tecer mais esclarecimentos...

Grato,

Ola, estranho, com os 3 ficheiros de exemplo a fazer ao mesmo tempo, faz bem?
Abraço

Olá,

Não está fazendo correto. Quando olho a descrição com o valor total pago tá com erro.
vou citar uma linha da importação como exemplo.
Aguarde um momento.

Ok Gomes, fico no aguardo, caso tenha diferenças, envie tambem como menagem nº 19 e o xml em questão.
Abraço

Estava mechendo ontem para enviar para o fórum, porém, minha energia acabou e não consegui enviar.

Olá Gomes, recebi a tua MP, no entanto sou da opinião que a troca de informações deve ser efetuada aqui, mantendo a razão do fórum.
Se eventualmente tiver algum ficheiro mais sensível ou pretende proteger a privacidade, não tenho qualquer problema em receber através de MP, no entanto o diálogo deve ficar aqui para os restantes colegas.  


Bom relativamente ao tópico:

1º Verifica se está a utilizar a ultima versão disponibilizada (pois à primeira vista o ficheiro ENVIO_LOTE_GUIAS_doc_40774_id_26185.xml está a importar conforme tabela de exemplo).

2º Para verificar o que se está a passar necessito:
  2A - ficheiro xml: XML ENVIO_LOTE_GUIAS_doc_40113_id_26695
  2B - ficheiro que dá o erro "Erro de sintaxe na data na expressão de consulta ‘#’" a importar.

Abraço

Olá, 

Após analise do código, segue considerações do arquivo, pois o valor total do XML é 60.146,74, e está importando apenas 19.155,98.

Apresenta (Erro de sintaxe na data na expressão de consulta ‘#’). O ficheiro que da erro é o ENVIO_LOTE_GUIAS_doc_40113_id_26695 consta no link abaixo:

Todos os demais arquivos eu estou conseguindo importar em lotes sem problemas, porém, o XML ENVIO_LOTE_GUIAS_doc_40113_id_26695, não está sendo importado os registros pelo fato de ser ficheiro do tipo guiaResumoInternacao, e o XML possui somente dataExecucao.



Nesse tipo de arquivo não tem dataInicioFaturamento nem dataFinalFaturamento, somente dataExecucao.

Link Tabela: https://www.dropbox.com/s/1caghn4mp3ap7xd/extrairCampoXml_registo_v4.rar?dl=0

Link Campos XML: [url=https://www.dropbox.com/s/d7jfbqk47rnz3jw/Campos xml.rar?dl=0]https://www.dropbox.com/s/d7jfbqk47rnz3jw/Campos%20XML.rar?dl=0[/url]


Atenciosamente,

Olá Gomes, arranjei um tempinho e acabei de testar na ultima versao, não deu erro e o total é 60146,97
Veja a versão que está a utilizar V4 (mensagem n.º 56) o código é este (e o qual efetuei o teste):

Código:

Option Compare Database
Dim meuFicheiro As String, txtLinha As String, textoLinha As String

Private Sub Comando0_Click()
'2014 Alvaro Teixeira - extrairCampoXml_registo_v4
Dim Importar, Proce As Integer
textoLinha = ""
Importar = 0

Dim xCodGuia$ 'senha
Dim xCodUsuario$ 'numeroCarteira
Dim xNomeUsuario$ 'nomeBeneficiario
Dim xDtAtendimento$ 'dataInicioFaturamento    -       dataExecucao
Dim xDtAlta$ 'dataFinalFaturamento
Dim xCodServico$ 'codigoProcedimento
Dim xNomeServico$ 'descricaoProcedimento
Dim xQuantidadeServico$ 'quantidadeExecutada
Dim xReferencia$ 'valorUnitario
Dim xValorPago$ 'valorTotal


'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40729_id_26191.xml"
'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40765_id_26192.xml"
'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40113_id_26302.xml"
meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40113_id_26695.xml"
    
    
Open meuFicheiro For Input As #1
    Do Until EOF(1)
         Line Input #1, txtLinha
              
             '-------------- verifica tipo de ficheiro
              If InStr(txtLinha, "<ans:guiaSP-SADT>") > 0 Then Importar = 1 ' guiaSP-SADT
              If InStr(txtLinha, "<ans:guiaResumoInternacao>") > 0 Then Importar = 2 ' guiaResumoInternacao>
              textoLinha = textoLinha & txtLinha
          
              'Inicio - guiaSP-SADT
               If InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 1 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 1 Then
                 If InStr(textoLinha, "<ans:senha>") > 0 Then xCodGuia = extrairCampoXml(textoLinha, "ans:senha")
                 If InStr(textoLinha, "<ans:numeroCarteira>") > 0 Then xCodUsuario = extrairCampoXml(textoLinha, "ans:numeroCarteira")
                 If InStr(textoLinha, "<ans:nomeBeneficiario>") > 0 Then xNomeUsuario = extrairCampoXml(textoLinha, "ans:nomeBeneficiario")
                 If InStr(textoLinha, "<ans:dataExecucao>") > 0 Then xDtAtendimento = extrairCampoXml(textoLinha, "ans:dataExecucao"): xDtAtendimento = Right(xDtAtendimento, 2) & "-" & Mid(xDtAtendimento, 6, 2) & "-" & Left(xDtAtendimento, 4)
                 If InStr(textoLinha, "<ans:codigoProcedimento>") > 0 Then xCodServico = extrairCampoXml(textoLinha, "ans:codigoProcedimento")
                 If InStr(textoLinha, "<ans:descricaoProcedimento>") > 0 Then xNomeServico = extrairCampoXml(textoLinha, "ans:descricaoProcedimento")
                 If InStr(textoLinha, "<ans:quantidadeExecutada>") > 0 Then xQuantidadeServico = Replace(extrairCampoXml(textoLinha, "ans:quantidadeExecutada"), ".", ",") 'alterara separador decimais
                 If InStr(textoLinha, "<ans:valorUnitario>") > 0 Then xReferencia = Replace(extrairCampoXml(textoLinha, "ans:valorUnitario"), ".", ",") 'alterara separador decimais
                 If InStr(textoLinha, "<ans:valorTotal>") > 0 Then xValorPago = Replace(extrairCampoXml(textoLinha, "ans:valorTotal"), ".", ",") 'alterara separador decimais
                 'executa consulta
                    CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento,  CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago ) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', #" & Format(xDtAtendimento, "mm/dd/yyyy") & "# , " _
                    & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                End If
                'limpa
                If InStr(txtLinha, "</ans:procedimentosExecutados>") > 0 And Importar = 1 Then textoLinha = "" 'antes processar serviços
                If InStr(txtLinha, "</ans:guiaSP-SADT>") > 0 And Importar = 1 Then
                       Importar = 0
                       textoLinha = ""
                       xCodGuia = ""
                       xCodUsuario = ""
                       xNomeUsuario = ""
                       xDtAtendimento = ""
                       xDtAlta = ""
                       xCodServico = ""
                       xNomeServico = ""
                       xQuantidadeServico = ""
                       xReferencia = ""
                       xValorPago = ""
                End If
              'Fim - guiaSP-SADT
              
              '---------------------------------------------------------------------------------------------------------------------------------------
              '---------------------------------------------------------------------------------------------------------------------------------------
              
              'Inicio - guiaResumoInternacao
              If InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 2 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 2 Then
                 If InStr(textoLinha, "<ans:senha>") > 0 Then xCodGuia = extrairCampoXml(textoLinha, "ans:senha")
                 If InStr(textoLinha, "<ans:numeroCarteira>") > 0 Then xCodUsuario = extrairCampoXml(textoLinha, "ans:numeroCarteira")
                 If InStr(textoLinha, "<ans:nomeBeneficiario>") > 0 Then xNomeUsuario = extrairCampoXml(textoLinha, "ans:nomeBeneficiario")
                 If InStr(textoLinha, "<ans:dataExecucao>") > 0 Then xDtAtendimento = extrairCampoXml(textoLinha, "ans:dataExecucao"): xDtAtendimento = Right(xDtAtendimento, 2) & "-" & Mid(xDtAtendimento, 6, 2) & "-" & Left(xDtAtendimento, 4)
                 'If InStr(textoLinha, "<ans:dataFinalFaturamento>") > 0 Then xDtAlta = extrairCampoXml(textoLinha, "ans:dataFinalFaturamento"): xDtAlta = Right(xDtAlta, 2) & "-" & Mid(xDtAlta, 6, 2) & "-" & Left(xDtAlta, 4)
                 If InStr(textoLinha, "<ans:codigoProcedimento>") > 0 Then xCodServico = extrairCampoXml(textoLinha, "ans:codigoProcedimento")
                 If InStr(textoLinha, "<ans:descricaoProcedimento>") > 0 Then xNomeServico = extrairCampoXml(textoLinha, "ans:descricaoProcedimento")
                 If InStr(textoLinha, "<ans:quantidadeExecutada>") > 0 Then xQuantidadeServico = Replace(extrairCampoXml(textoLinha, "ans:quantidadeExecutada"), ".", ",") 'alterara separador decimais
                 If InStr(textoLinha, "<ans:valorUnitario>") > 0 Then xReferencia = Replace(extrairCampoXml(textoLinha, "ans:valorUnitario"), ".", ",") 'alterara separador decimais
                 If InStr(textoLinha, "<ans:valorTotal>") > 0 Then xValorPago = Replace(extrairCampoXmlRev(textoLinha, "ans:valorTotal"), ".", ",") 'alterara separador decimais, função reverse por causa do problema do valor campo duplicado para varios nós diferentes
                 'executa consulta
                    CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento,  CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago ) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', #" & Format(xDtAtendimento, "mm/dd/yyyy") & "# , " _
                    & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                End If
                 'limpa
                 If InStr(txtLinha, "</ans:guiaResumoInternacao>") > 0 And Importar = 2 Then
                       Importar = 0
                       textoLinha = ""
                       xCodGuia = ""
                       xCodUsuario = ""
                       xNomeUsuario = ""
                       xDtAtendimento = ""
                       xDtAlta = ""
                       xCodServico = ""
                       xNomeServico = ""
                       xQuantidadeServico = ""
                       xReferencia = ""
                       xValorPago = ""
                 End If
              'Fim - guiaResumoInternacao
    Loop
Close #1
MsgBox "Concluído", vbInformation, ""

End Sub

'2014 Alvaro Teixeira
Function extrairCampoXml(strLinha As String, strNomeCampo As String)
Dim strInicio As String
Dim strFim As String
strInicio = "<" & strNomeCampo & ">"
strFim = "</" & strNomeCampo & ">"

Dim i As Long, j As Long
    i = InStr(strLinha, strInicio)
    j = InStr(strLinha, strFim)
    extrairCampoXml = Mid(strLinha, i + Len(strInicio), j - i - Len(strInicio))
End Function

'2014 Alvaro Teixeira
Function extrairCampoXmlRev(strLinha As String, strNomeCampo As String)
Dim strInicio As String
Dim strFim As String
strInicio = "<" & strNomeCampo & ">"
strFim = "</" & strNomeCampo & ">"

Dim i As Long, j As Long
    i = InStrRev(strLinha, strInicio)
    j = InStrRev(strLinha, strFim)
    extrairCampoXmlRev = Mid(strLinha, i + Len(strInicio), j - i - Len(strInicio))
End Function


Abraço

Olá Gomes, como vai a situação, já testou conforme indicações!!!
Aguardamos retorno, os utilizadores do fórum agradecem.
Abraço.

Olá prezado,
Estou adaptando ele agora para trazer as informações.

Já já eu posto o código com o exemplo.
Minha semana foi corrida e eu não consegui mexer no decorrer da semana.

Grato,

Olá,

Consegui adaptar o código para trazer todos os registros dos ficheiros Sadt e Internação, porém, está faltando trazer a data de Alta quando ficheiro é de Internação. Ex: ENVIO_LOTE_GUIAS_doc_40113_id_26695.

Link abaixo.
https://www.dropbox.com/s/665wavsmrhmmggq/extrairCampoXml_registo_v5.rar?dl=0

Código:

Option Compare Database
Dim meuFicheiro As String, txtLinha As String, textoLinha As String

Private Sub Comando0_Click()
'2014 Alvaro Teixeira - extrairCampoXml_registo_v4
Dim Importar, Proce As Integer
textoLinha = ""
Importar = 0

Dim xCodGuia$ 'senha
Dim xCodUsuario$ 'numeroCarteira
Dim xNomeUsuario$ 'nomeBeneficiario
Dim xDtAtendimento$ 'dataInicioFaturamento    -       dataExecucao
Dim xDtAlta$ 'dataFinalFaturamento
Dim xCodServico$ 'codigoProcedimento
Dim xNomeServico$ 'descricaoProcedimento
Dim xQuantidadeServico$ 'quantidadeExecutada
Dim xReferencia$ 'valorUnitario
Dim xValorPago$ 'valorTotal


'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40729_id_26191.xml"'ok
'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40765_id_26192.xml" 'não importa datas
meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40113_id_26695.xml" 'não importa datas
'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40774_id_26185.xml" 'ok
    
Open meuFicheiro For Input As #1
    Do Until EOF(1)
         Line Input #1, txtLinha
              
             '-------------- verifica tipo de ficheiro XML ---------------------
             '-------------- verifica tipo de ficheiro XML ---------------------
              If InStr(txtLinha, "<ans:guiaSP-SADT>") > 0 Then Importar = 1 ' guiaSP-SADT
              If InStr(txtLinha, "<ans:guiaResumoInternacao>") > 0 Then Importar = 2 ' guiaResumoInternacao
              'If InStr(txtLinha, "<ans:guiaResumoInternacao>") > 0 Then Importar = 3   ' guiaResumoInternacao sem data  de alta
               textoLinha = textoLinha & txtLinha
              
              'Inicio - guiaSP-SADT
              
                If InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 1 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 1 Then
                If InStr(textoLinha, "<ans:senha>") > 0 Then xCodGuia = extrairCampoXml(textoLinha, "ans:senha")
                If InStr(textoLinha, "<ans:numeroCarteira>") > 0 Then xCodUsuario = extrairCampoXml(textoLinha, "ans:numeroCarteira")
                If InStr(textoLinha, "<ans:nomeBeneficiario>") > 0 Then xNomeUsuario = extrairCampoXml(textoLinha, "ans:nomeBeneficiario")
                If InStr(textoLinha, "<ans:dataExecucao>") > 0 Then xDtAtendimento = extrairCampoXml(textoLinha, "ans:dataExecucao"): xDtAtendimento = Right(xDtAtendimento, 2) & "-" & Mid(xDtAtendimento, 6, 2) & "-" & Left(xDtAtendimento, 4)
                If InStr(textoLinha, "<ans:codigoProcedimento>") > 0 Then xCodServico = extrairCampoXml(textoLinha, "ans:codigoProcedimento")
                If InStr(textoLinha, "<ans:descricaoProcedimento>") > 0 Then xNomeServico = extrairCampoXml(textoLinha, "ans:descricaoProcedimento")
                If InStr(textoLinha, "<ans:quantidadeExecutada>") > 0 Then xQuantidadeServico = Replace(extrairCampoXml(textoLinha, "ans:quantidadeExecutada"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorUnitario>") > 0 Then xReferencia = Replace(extrairCampoXml(textoLinha, "ans:valorUnitario"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorTotal>") > 0 Then xValorPago = Replace(extrairCampoXml(textoLinha, "ans:valorTotal"), ".", ",") 'alterara separador decimais
                
                 'Execulta consulta
                    
                    CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento,  CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', #" & Format(xDtAtendimento, "mm/dd/yyyy") & "# , " _
                    & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                
                 'limpa
                
                End If
                
                If InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 1 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 1 Then textoLinha = ""
                If InStr(txtLinha, "</ans:guiaSP-SADT>") > 0 And Importar = 1 Then
                
                'If InStr(txtLinha, "</ans:procedimentosExecutados>") > 0 And Importar = 1 Then textoLinha = "" ' Código inserido.
                'If InStr(txtLinha, "</ans:guiaSP-SADT>") > 0 And Importar = 1 Then ' Código inserido.
                 Importar = 0
                 textoLinha = ""
                 xCodGuia = ""
                 xCodUsuario = ""
                 xNomeUsuario = ""
                 xDtAtendimento = ""
                 xDtAlta = ""
                 xCodServico = ""
                 xNomeServico = ""
                 xQuantidadeServico = ""
                 xReferencia = ""
                 xValorPago = ""
              
              'Fim - guiaSP-SADT
              
              '---------------------------------------------------------------------------------------------------------------------------------------
              
              'Inicio - guiaResumoInternacao
              
                ElseIf InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 2 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 2 Then
                If InStr(textoLinha, "<ans:senha>") > 0 Then xCodGuia = extrairCampoXml(textoLinha, "ans:senha")
                If InStr(textoLinha, "<ans:numeroCarteira>") > 0 Then xCodUsuario = extrairCampoXml(textoLinha, "ans:numeroCarteira")
                If InStr(textoLinha, "<ans:nomeBeneficiario>") > 0 Then xNomeUsuario = extrairCampoXml(textoLinha, "ans:nomeBeneficiario")
                If InStr(textoLinha, "<ans:dataExecucao>") > 0 Then xDtAtendimento = extrairCampoXml(textoLinha, "ans:dataExecucao"): xDtAtendimento = Right(xDtAtendimento, 2) & "-" & Mid(xDtAtendimento, 6, 2) & "-" & Left(xDtAtendimento, 4)
                If InStr(textoLinha, "<ans:codigoProcedimento>") > 0 Then xCodServico = extrairCampoXml(textoLinha, "ans:codigoProcedimento")
                If InStr(textoLinha, "<ans:descricaoProcedimento>") > 0 Then xNomeServico = extrairCampoXml(textoLinha, "ans:descricaoProcedimento")
                If InStr(textoLinha, "<ans:quantidadeExecutada>") > 0 Then xQuantidadeServico = Replace(extrairCampoXml(textoLinha, "ans:quantidadeExecutada"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorUnitario>") > 0 Then xReferencia = Replace(extrairCampoXml(textoLinha, "ans:valorUnitario"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorTotal>") > 0 Then xValorPago = Replace(extrairCampoXmlRev(textoLinha, "ans:valorTotal"), ".", ",") 'alterara separador decimais, função reverse por causa do problema do valor campo duplicado para varios nós diferentes
                
                 'Execulta consulta
  
                    CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento,  CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago ) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', #" & Format(xDtAtendimento, "mm/dd/yyyy") & "# , " _
                    & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                    textoLinha = ""
                
                
                End If
                
                 'limpa
                    
                If InStr(txtLinha, "</ans:procedimentosExecutados>") > 0 And Importar = 2 Then textoLinha = "" ' Código inserido.
                If InStr(txtLinha, "</ans:guiaResumoInternacao>") > 0 And Importar = 2 Then
                      
                       Importar = 0
                       textoLinha = ""
                       xCodGuia = ""
                       xCodUsuario = ""
                       xNomeUsuario = ""
                       xDtAtendimento = ""
                       xDtAlta = ""
                       xCodServico = ""
                       xNomeServico = ""
                       xQuantidadeServico = ""
                       xReferencia = ""
                       xValorPago = ""
                 'End If
                                
                ElseIf InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 2 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 2 Then
                If InStr(textoLinha, "<ans:senha>") > 0 Then xCodGuia = extrairCampoXml(textoLinha, "ans:senha")
                If InStr(textoLinha, "<ans:numeroCarteira>") > 0 Then xCodUsuario = extrairCampoXml(textoLinha, "ans:numeroCarteira")
                If InStr(textoLinha, "<ans:nomeBeneficiario>") > 0 Then xNomeUsuario = extrairCampoXml(textoLinha, "ans:nomeBeneficiario")
                ElseIf InStr(textoLinha, "<ans:dataInicioFaturamento>") > 0 Then xDtAtendimento = extrairCampoXml(textoLinha, "ans:dataInicioFaturamento"): xDtAtendimento = Right(xDtAtendimento, 2) & "-" & Mid(xDtAtendimento, 6, 2) & "-" & Left(xDtAtendimento, 4)
                ElseIf InStr(textoLinha, "<ans:dataFinalFaturamento>") > 0 Then xDtAlta = extrairCampoXml(textoLinha, "ans:dataFinalFaturamento"): xDtAlta = Right(xDtAlta, 2) & "-" & Mid(xDtAlta, 6, 2) & "-" & Left(xDtAlta, 4)
                If InStr(textoLinha, "<ans:codigoProcedimento>") > 0 Then xCodServico = extrairCampoXml(textoLinha, "ans:codigoProcedimento")
                If InStr(textoLinha, "<ans:descricaoProcedimento>") > 0 Then xNomeServico = extrairCampoXml(textoLinha, "ans:descricaoProcedimento")
                If InStr(textoLinha, "<ans:quantidadeExecutada>") > 0 Then xQuantidadeServico = Replace(extrairCampoXml(textoLinha, "ans:quantidadeExecutada"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorUnitario>") > 0 Then xReferencia = Replace(extrairCampoXml(textoLinha, "ans:valorUnitario"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorTotal>") > 0 Then xValorPago = Replace(extrairCampoXmlRev(textoLinha, "ans:valorTotal"), ".", ",") 'alterara separador decimais, função reverse por causa do problema do valor campo duplicado para varios nós diferentes
                
                 'Execulta consulta
  
                    CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento, DtAlta, CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago ) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', #" & Format(xDtAtendimento, "mm/dd/yyyy") & "# , #" _
                    & Format(xDtAlta, "mm/dd/yyyy") & "# , " & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                    textoLinha = ""
                End If
                
                 'limpa
                
                If InStr(txtLinha, "</ans:procedimentosExecutados>") > 0 And Importar = 2 Then textoLinha = "" ' Código inserido.
                If InStr(txtLinha, "</ans:guiaResumoInternacao>") > 0 And Importar = 2 Then
                      
                       Importar = 0
                       textoLinha = ""
                       xCodGuia = ""
                       xCodUsuario = ""
                       xNomeUsuario = ""
                       xDtAtendimento = ""
                       xDtAlta = ""
                       xCodServico = ""
                       xNomeServico = ""
                       xQuantidadeServico = ""
                       xReferencia = ""
                       xValorPago = ""
                End If
                
                 'Final - guiaResumoInternacao sem dataFinalFaturamento no XMl
                 '---------------------------------------------------------------------------------------------------------------------------------------
    Loop

Close #1
MsgBox "Concluído", vbInformation, ""

End Sub

'2014 Alvaro Teixeira
Function extrairCampoXml(strLinha As String, strNomeCampo As String)
Dim strInicio As String
Dim strFim As String
strInicio = "<" & strNomeCampo & ">"
strFim = "</" & strNomeCampo & ">"

Dim i As Long, j As Long
    i = InStr(strLinha, strInicio)
    j = InStr(strLinha, strFim)
    extrairCampoXml = Mid(strLinha, i + Len(strInicio), j - i - Len(strInicio))
End Function
'2014 Alvaro Teixeira
Function extrairCampoXmlRev(strLinha As String, strNomeCampo As String)
Dim strInicio As String
Dim strFim As String
strInicio = "<" & strNomeCampo & ">"
strFim = "</" & strNomeCampo & ">"

Dim i As Long, j As Long
    i = InStrRev(strLinha, strInicio)
    j = InStrRev(strLinha, strFim)
    extrairCampoXmlRev = Mid(strLinha, i + Len(strInicio), j - i - Len(strInicio))
End Function


Ola, estou no telemóvel e não posso ajudar muito.
Mas está na hora de perder o medo e fazer a alteração.
Se reparar no código da mensagem n. 65 a instrução ja estava feita, não sei quem colocou a aspa simples para não processar.
Inclua a seguinte linha:

'If InStr(textoLinha, "") > 0 Then xDtAlta = extrairCampoXml(textoLinha, "ans:dataFinalFaturamento"): xDtAlta = Right(xDtAlta, 2) & "-" & Mid(xDtAlta, 6, 2) & "-" & Left(xDtAlta, 4)

Abraço

Olá,
Estou a dias fazendo mudanças para chegar ao que desejo.

Vou incluir a linha sugerida para ver como fica.

Grato,

Olá,

Falta um detalhe mínimo para concluir o processo.

Descobri aonde esta o erro, era no código que lê o ficheiro do tipo ans:guiaResumoInternacao, pois o código está importando para a tabela apenas os registros que possui ans:dataInicioFaturamento e ans:dataFinalFaturamento > 0 os demais registros que possui somente ans:dataExecucao são ignorados e gera erro na consulta que leva os dados para tabela por não ter ans:dataInicioFaturamento e ans:dataFinalFaturamento.

O erro é no ficheiro meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40113_id_26695.xml"

Código:

On Error Resume Next
                    'Com o erro gerado acima, a consulta não prossegue...Da erro!!!
                    CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento, DtAlta, CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago ) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', #" & Format(xDtAtendimento, "mm/dd/yyyy") & "# , #" _
                    & Format(xDtAlta, "mm/dd/yyyy") & "# , " & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                    textoLinha = ""


Link: https://www.dropbox.com/s/665wavsmrhmmggq/extrairCampoXml_registo_v5.rar?dl=0

Grato,

Olá Gomes, entes de verificar a questão da mensagem anteriror, explica-me o seguinte:

1) Qual a razão das duas linhas abaixo estarem a ser excluídas (aspa simples) ao rolar o código na importação do tipo 1 ?

Código:

                If InStr(txtLinha, "</ans:procedimentosExecutados>") > 0 And Importar = 1 Then textoLinha = "" 'antes processar serviços
                If InStr(txtLinha, "</ans:guiaSP-SADT>") > 0 And Importar = 1 Then

No aguardo

Olá,

Foi excluido por erro de minha parte, pois estava fazendo algumas modificações ontem e esqueci de habilitá-los novamente.

Falta somente a questão anterior para sanar os problemas no código.

Grato,

Ok,
1) efetue a rectificação e volte a postar a última versao que tem.
2) se possivel pode fazer uma tabela exemplificativa (como habitual) dos dados a importar, será suficiente de um paciente, pode ser o WALDOMIRO GIACOMO COMETTI

Olá,

Segue tabela modelo de como o código deve trazer todos os dados do ficheiro.


https://www.dropbox.com/s/665wavsmrhmmggq/extrairCampoXml_registo_v5.rar?dl=0

Grato,

Olá Gomes, está a dar erro.
No aguardo. Abraço

Olá, boa tarde,

Segue link novamente.

https://www.dropbox.com/s/665wavsmrhmmggq/extrairCampoXml_registo_v5.rar?dl=0

Olá Gomes, o código tem diversas aterações, já testou nos vários tipos de ficheiro e o unico ponto em que está a falhar é o relatado na mensagem nº 71?
Aguardo retorno?

Olá,

Sim está correto, pois o único XML que não consigo importar é o ENVIO_LOTE_GUIAS_doc_40113_id_26695.

Os demais não da erro.

Olá, você colocou no codigo um ELSEIF e alterou a forma de como estava a controlar os ficheiros de importação,
por isso a razão da minha questão, se está tudo mesmo a funcionar, vou verificar apenas o que pretende.
Abraço

Olá,

Perfeito amigo.

Acabei de fazer novos testes e o dados dos outros ficheiros estão importando, apenas o ENVIO_LOTE_GUIAS_doc_40113_id_26695 que não consigo todos os dados.

Qualquer eventualidade eu altero para IF.

Grato pela atenção.

Gomes, coloque o codigo abaixo no seu ultimo exemplo postado (mensagem n. 77).

Código:

Option Compare Database
Dim meuFicheiro As String, txtLinha As String, textoLinha As String

Private Sub Comando0_Click()
'2014 Alvaro Teixeira - extrairCampoXml_registo_v6 - 23-01-2015
Dim Importar, Proce As Integer
textoLinha = ""
Importar = 0

Dim xCodGuia$ 'senha
Dim xCodUsuario$ 'numeroCarteira
Dim xNomeUsuario$ 'nomeBeneficiario
Dim xDtAtendimento$ 'dataInicioFaturamento    -       dataExecucao
Dim xDtAlta$ 'dataFinalFaturamento
Dim xCodServico$ 'codigoProcedimento
Dim xNomeServico$ 'descricaoProcedimento
Dim xQuantidadeServico$ 'quantidadeExecutada
Dim xReferencia$ 'valorUnitario
Dim xValorPago$ 'valorTotal


'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40729_id_26191.xml"'ok
'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40765_id_26192.xml" 'não importa datas
meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40113_id_26695.xml" 'não importa datas
'meuFicheiro = Application.CurrentProject.Path & "\ENVIO_LOTE_GUIAS_doc_40774_id_26185.xml" 'ok
    
Open meuFicheiro For Input As #1
    Do Until EOF(1)
         Line Input #1, txtLinha
              
              If InStr(txtLinha, "<ans:guiaSP-SADT>") > 0 Then Importar = 1 ' guiaSP-SADT
              If InStr(txtLinha, "<ans:guiaResumoInternacao>") > 0 Then Importar = 2 ' guiaResumoInternacao
               textoLinha = textoLinha & txtLinha
          
              'Inicio - guiaSP-SADT
              
                If InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 1 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 1 Then
                If InStr(textoLinha, "<ans:senha>") > 0 Then xCodGuia = extrairCampoXml(textoLinha, "ans:senha")
                If InStr(textoLinha, "<ans:numeroCarteira>") > 0 Then xCodUsuario = extrairCampoXml(textoLinha, "ans:numeroCarteira")
                If InStr(textoLinha, "<ans:nomeBeneficiario>") > 0 Then xNomeUsuario = extrairCampoXml(textoLinha, "ans:nomeBeneficiario")
                If InStr(textoLinha, "<ans:dataExecucao>") > 0 Then xDtAtendimento = extrairCampoXml(textoLinha, "ans:dataExecucao"): xDtAtendimento = Right(xDtAtendimento, 2) & "-" & Mid(xDtAtendimento, 6, 2) & "-" & Left(xDtAtendimento, 4)
                If InStr(textoLinha, "<ans:codigoProcedimento>") > 0 Then xCodServico = extrairCampoXml(textoLinha, "ans:codigoProcedimento")
                If InStr(textoLinha, "<ans:descricaoProcedimento>") > 0 Then xNomeServico = extrairCampoXml(textoLinha, "ans:descricaoProcedimento")
                If InStr(textoLinha, "<ans:quantidadeExecutada>") > 0 Then xQuantidadeServico = Replace(extrairCampoXml(textoLinha, "ans:quantidadeExecutada"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorUnitario>") > 0 Then xReferencia = Replace(extrairCampoXml(textoLinha, "ans:valorUnitario"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorTotal>") > 0 Then xValorPago = Replace(extrairCampoXml(textoLinha, "ans:valorTotal"), ".", ",") 'alterara separador decimais
                
                 'Execulta consulta
                    
                    CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento,  CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', #" & Format(xDtAtendimento, "mm/dd/yyyy") & "# , " _
                    & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                
                 'limpa
                
                End If
                
                'If InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 1 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 1 Then textoLinha = ""
                'If InStr(txtLinha, "</ans:guiaSP-SADT>") > 0 And Importar = 1 Then
                
                If InStr(txtLinha, "</ans:procedimentosExecutados>") > 0 And Importar = 1 Then textoLinha = "" ' Código inserido, ver funcionamento.
                If InStr(txtLinha, "</ans:guiaSP-SADT>") > 0 And Importar = 1 Then ' Código inserido, ver funcionamento.
                
                 Importar = 0
                 textoLinha = ""
                 xCodGuia = ""
                 xCodUsuario = ""
                 xNomeUsuario = ""
                 xDtAtendimento = ""
                 xDtAlta = ""
                 xCodServico = ""
                 xNomeServico = ""
                 xQuantidadeServico = ""
                 xReferencia = ""
                 xValorPago = ""
              
              'Fim - guiaSP-SADT
              
              '---------------------------------------------------------------------------------------------------------------------------------------
              
              'Inicio - guiaResumoInternacao
               ElseIf InStr(txtLinha, "</ans:procedimentoExecutado>") > 0 And Importar = 2 Or InStr(txtLinha, "</ans:servicosExecutados>") > 0 And Importar = 2 Then
                If InStr(textoLinha, "<ans:senha>") > 0 Then xCodGuia = extrairCampoXml(textoLinha, "ans:senha")
                If InStr(textoLinha, "<ans:numeroCarteira>") > 0 Then xCodUsuario = extrairCampoXml(textoLinha, "ans:numeroCarteira")
                If InStr(textoLinha, "<ans:nomeBeneficiario>") > 0 Then xNomeUsuario = extrairCampoXml(textoLinha, "ans:nomeBeneficiario")
                If InStr(textoLinha, "<ans:dataInicioFaturamento>") > 0 Then xDtAtendimento = extrairCampoXml(textoLinha, "ans:dataInicioFaturamento"): xDtAtendimento = Right(xDtAtendimento, 2) & "-" & Mid(xDtAtendimento, 6, 2) & "-" & Left(xDtAtendimento, 4)
                
                ' O erro de importação está nessa linha
                If InStr(textoLinha, "<ans:dataExecucao>") > 0 Then xDtAtendimento = extrairCampoXml(textoLinha, "ans:dataExecucao"): xDtAtendimento = Right(xDtAtendimento, 2) & "-" & Mid(xDtAtendimento, 6, 2) & "-" & Left(xDtAtendimento, 4)
                
                If InStr(textoLinha, "<ans:dataFinalFaturamento>") > 0 Then xDtAlta = extrairCampoXml(textoLinha, "ans:dataFinalFaturamento"): xDtAlta = Right(xDtAlta, 2) & "-" & Mid(xDtAlta, 6, 2) & "-" & Left(xDtAlta, 4)
                If InStr(textoLinha, "<ans:codigoProcedimento>") > 0 Then xCodServico = extrairCampoXml(textoLinha, "ans:codigoProcedimento")
                If InStr(textoLinha, "<ans:descricaoProcedimento>") > 0 Then xNomeServico = extrairCampoXml(textoLinha, "ans:descricaoProcedimento")
                If InStr(textoLinha, "<ans:quantidadeExecutada>") > 0 Then xQuantidadeServico = Replace(extrairCampoXml(textoLinha, "ans:quantidadeExecutada"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorUnitario>") > 0 Then xReferencia = Replace(extrairCampoXml(textoLinha, "ans:valorUnitario"), ".", ",") 'alterara separador decimais
                If InStr(textoLinha, "<ans:valorTotal>") > 0 Then xValorPago = Replace(extrairCampoXmlRev(textoLinha, "ans:valorTotal"), ".", ",") 'alterara separador decimais, função reverse por causa do problema do valor campo duplicado para varios nós diferentes
                
                 'Execulta consulta
                    'Com o erro gerado acima, a consulta não prossegue...Da erro!!!
                    CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento, DtAlta,  CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago ) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', " & IIf(Len(xDtAtendimento) = 0, "'" & Null & "'", "#" & Format(xDtAtendimento, "mm/dd/yyyy") & "#") & " , " _
                    & IIf(Len(xDtAlta) = 0, "'" & Null & "'", "#" & Format(xDtAlta, "mm/dd/yyyy") & "#") & " , " & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                    
                    'On Error Resume Next
                    'CurrentDb.Execute "INSERT INTO Enviado (CódGuia, CódUsuário, NomeUsuário, DtAtendimento, DtAlta, CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago ) SELECT " & xCodGuia _
                    & ",'" & Format(xCodUsuario, "00000000000000000") & "','" & xNomeUsuario & "', #" & Format(xDtAtendimento, "mm/dd/yyyy") & "# , #" _
                    & Format(xDtAlta, "mm/dd/yyyy") & "# , " & xCodServico & ", '" & xNomeServico & "', '" & xQuantidadeServico & "', '" & xReferencia & "', '" & xValorPago & "';"
                    textoLinha = ""
                
               End If
                
                 'limpa
                If InStr(txtLinha, "</ans:procedimentosExecutados>") > 0 And Importar = 2 Then textoLinha = "" ' Código inserido.
                If InStr(txtLinha, "</ans:guiaResumoInternacao>") > 0 And Importar = 2 Then
                      
                       Importar = 0
                       textoLinha = ""
                       xCodGuia = ""
                       xCodUsuario = ""
                       xNomeUsuario = ""
                       xDtAtendimento = ""
                       xDtAlta = ""
                       xCodServico = ""
                       xNomeServico = ""
                       xQuantidadeServico = ""
                       xReferencia = ""
                       xValorPago = ""
                
                End If
                
                 'Final - guiaResumoInternacao

    Loop
Close #1
MsgBox "Concluído", vbInformation, ""

End Sub

'2014 Alvaro Teixeira
Function extrairCampoXml(strLinha As String, strNomeCampo As String)
Dim strInicio As String
Dim strFim As String
strInicio = "<" & strNomeCampo & ">"
strFim = "</" & strNomeCampo & ">"

Dim i As Long, j As Long
    i = InStr(strLinha, strInicio)
    j = InStr(strLinha, strFim)
    extrairCampoXml = Mid(strLinha, i + Len(strInicio), j - i - Len(strInicio))
End Function
'2014 Alvaro Teixeira
Function extrairCampoXmlRev(strLinha As String, strNomeCampo As String)
Dim strInicio As String
Dim strFim As String
strInicio = "<" & strNomeCampo & ">"
strFim = "</" & strNomeCampo & ">"

Dim i As Long, j As Long
    i = InStrRev(strLinha, strInicio)
    j = InStrRev(strLinha, strFim)
    extrairCampoXmlRev = Mid(strLinha, i + Len(strInicio), j - i - Len(strInicio))
End Function


No aguardo, abraço

Prezado ahteixeira,

Após adaptação verifiquei que o código funcionou muito bem.

Obrigado pela paciência e dedicação em ajudar-me.

Olá Gomes, obrigado pelo retorno.
Abraço