Opa Erinaldo... Eu estava conseguindo com o Line porém os espaços estavam sendo um problema...
Com sua dica quanto ao VbTab Ficou perfeito!!!!!
Obrigado a todos pela Ajuda
Código completo
Function ImportaXML(Arquivo As String)
'-----------------------
'Declaração de Variáveis
'-----------------------
Dim strLinha As String
Dim strLInha1
Dim nLinha As Integer
Dim StrArquivo As String
Dim StrNumCarteira As String
Dim StrNomeBen As String
Dim StrSenhaAut As String
Dim dtDataHoraInt
Dim dtDataHoraSai
Dim lngCodigo As Long
Dim StrDescricao As String
Dim dblQtdRealiza As Double
Dim dblReferencia As Double
Dim dblValorTotal As Double
Dim strTMP, strTMP1
'-------------------
'Abre o arquivo xml
'-------------------
Open Arquivo For Input As #1
Do While Not EOF(1)
Line Input #1, strLinha
strLinha = LTrim(Replace(strLinha, vbTab, " ")) 'substitui as tabulações por espaços e corta os espaços
If Mid(left(strLinha, 23), 2, Len(left(strLinha, 23))) = "ansTISS:numeroCarteira" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
StrNumCarteira = Mid(strLinha, 25, InStrRev(strLinha, "<") - 25)
ElseIf Mid(left(strLinha, 25), 2, Len(left(strLinha, 25))) = "ansTISS:nomeBeneficiario" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
StrNomeBen = Mid(strLinha, 27, InStrRev(strLinha, "<") - 27)
ElseIf Mid(left(strLinha, 25), 2, Len(left(strLinha, 25))) = "ansTISS:senhaAutorizacao" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
StrSenhaAut = Mid(strLinha, 27, InStrRev(strLinha, "<") - 27)
ElseIf Mid(left(strLinha, 27), 2, Len(left(strLinha, 27))) = "ansTISS:dataHoraInternacao" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
dtDataHoraInt = CDate(Format(Mid(strLinha, 29, InStrRev(strLinha, "<") - 38), "mm/dd/yyyy"))
ElseIf Mid(left(strLinha, 28), 2, Len(left(strLinha, 27))) = "ansTISS:dataHoraAtendimento" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
dtDataHoraInt = Mid(strLinha, 30, InStrRev(strLinha, "<") - 39)
ElseIf Mid(left(strLinha, 32), 2, Len(left(strLinha, 31))) = "ansTISS:dataHoraSaidaInternacao" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
dtDataHoraSai = CDate(Format(Mid(strLinha, 34, InStrRev(strLinha, "<") - 43), "mm/dd/yyyy"))
ElseIf Mid(left(strLinha, 16), 2, Len(left(strLinha, 16))) = "ansTISS:codigo>" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
lngCodigo = Mid(strLinha, 17, InStrRev(strLinha, "<") - 17)
ElseIf Mid(left(strLinha, 19), 2, Len(left(strLinha, 19))) = "ansTISS:descricao>" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
'strTMP = Mid(strLinha, Len(strLinha) - 19)
strTMP1 = left(strLinha, (Len(strLinha) - Len(strTMP)))
If right(strLinha, 20) = "" Then
StrDescricao = Mid(strTMP1, 20, (Len(strTMP1)))
Else
StrDescricao = Mid(strLinha, 20, (Len(strLinha)))
End If
ElseIf Mid(left(strLinha, 28), 2, Len(left(strLinha, 28))) = "ansTISS:quantidadeRealizada" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
strTMP1 = left(strLinha, (Len(strLinha) - Len(strTMP)))
If Len("" & strTMP1) = 0 Then
dblQtdRealiza = 0
Else
dblQtdRealiza = Replace(Nz(Mid(strTMP1, 30, (Len(strTMP1))), 0), ".", ",")
End If
ElseIf Mid(left(strLinha, 19), 2, Len(left(strLinha, 19))) = "ansTISS:quantidade" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
strTMP1 = left(strLinha, (Len(strLinha) - Len(strTMP)))
If Len("" & strTMP1) = 0 Then
dblQtdRealiza = 0
Else
dblQtdRealiza = Replace(Nz(Mid(strTMP1, 21, (Len(strTMP1))), 0), ".", ",")
End If
ElseIf Mid(left(strLinha, 15), 2, Len(left(strLinha, 15))) = "ansTISS:valor>" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
strTMP1 = left(strLinha, (Len(strLinha) - Len(strTMP)))
If Len("" & strTMP1) = 0 Then
dblReferencia = 0
Else
dblReferencia = Replace(Nz(Mid(strTMP1, 16, (Len(strTMP1))), 0), ".", ",")
End If
ElseIf Mid(left(strLinha, 23), 2, Len(left(strLinha, 23))) = "ansTISS:valorUnitario>" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
strTMP1 = left(strLinha, (Len(strLinha) - Len(strTMP)))
If Len("" & strTMP1) = 0 Then
dblReferencia = 0
Else
dblReferencia = Replace(Nz(Mid(strTMP1, 24, (Len(strTMP1))), 0), ".", ",")
End If
ElseIf Mid(left(strLinha, 19), 2, Len(left(strLinha, 19))) = "ansTISS:valorTotal" Then
strTMP = Mid(strLinha, InStrRev(strLinha, "<"))
strTMP1 = left(strLinha, (Len(strLinha) - Len(strTMP)))
If Len("" & strTMP1) = 0 Then
dblValorTotal = 0
Else
dblValorTotal = Replace(Nz(Mid(strTMP1, 21, (Len(strTMP1))), 0), ".", ",")
End If
'---------------------------
'Insere os valores na tabela
'---------------------------
'------------------------------------------------------
'Se a descrição não é nula e a dtDataHoraSai não é nula
'------------------------------------------------------
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("Enviado")
If Len("" & StrDescricao) > 0 And Len("" & dtDataHoraSai) > 0 Then
rs.AddNew
rs!NomeUsuário = StrNomeBen
rs!CódUsuário = StrNumCarteira
rs!CódGuia = StrSenhaAut
rs!CódServiço = lngCodigo
rs!DtAtendimento = dtDataHoraInt
rs!DtAlta = dtDataHoraSai
rs!NomeServiço = StrDescricao
rs!QuantidadeServiço = dblQtdRealiza
rs!Referencia = dblReferencia
rs!ValorPago = dblValorTotal
rs.Update
'--------------------------------------------------
'Se a descrição não é nula e a dtDataHoraSai é nula
'--------------------------------------------------
ElseIf Len("" & StrDescricao) > 0 And Len("" & dtDataHoraSai) = 0 Then
rs.AddNew
rs!NomeUsuário = StrNomeBen
rs!CódUsuário = StrNumCarteira
rs!CódGuia = StrSenhaAut
rs!CódServiço = lngCodigo
rs!DtAtendimento = CDate(dtDataHoraInt)
rs!NomeServiço = StrDescricao
rs!QuantidadeServiço = dblQtdRealiza
rs!Referencia = dblReferencia
rs!ValorPago = dblValorTotal
rs.Update
End If
StrDescricao = Empty
dblQtdRealiza = Empty
dblReferencia = Empty
dblValorTotal = Empty
strTMP = Empty
strTMP1 = Empty
End If
Loop
'------------------------------------
'Aplica na variável o nome do arquivo
'------------------------------------
StrArquivo = Mid(Arquivo, InStrRev(Arquivo, "\") + 1)
'---------------------------------------------------------------------------------
'Aplica na variável o nome do caminho que será gravado o arquivo + o nome do mesmo
'---------------------------------------------------------------------------------
novocaminho = CurrentProject.Path & "\ArquivosImportados\" & StrArquivo
'--------------------------
'Executa a cópia do arquivo
'--------------------------
FileCopy Arquivo, novocaminho
'---------------
'Fecha o arquivo
'---------------
Close #1
'--------------------------
'Deleta o arquivo de origem
'--------------------------
' Kill Arquivo
End Function