Windows 10 
Access 2003
Estou tentando importar dados de um ficheiro xml para a base de dados através do Vba.
Consegui fazer a mesma coisa com ficheiro .txt mas estou com dificuldades com o xml, criei um botão num formulário e ao clicar no botão ele importa dados para a tabela de uma pasta Chamada Ficheiro para outra pasta tratados.
Ficheiro xml:
<?xml version="1.0" encoding="ISO-8859-1"?>
<!-- created by ARS smart 0000034131 -->
<suppliers>
<data ID="55" S="2" Q="0" V="31710" V2="500" Long="-25721108" Lat="37770558" Avg="1" Dairy="1" Ves="1" Name="*****"/>
<data ID="59" S="2" Q="0" V="13240" V2="500" Long="-25245918" Lat="37769905" Avg="1" Dairy="1" Ves="1" Name="*****"/>
<data ID="71" S="2" Q="0" V="9450" V2="500" Long="-25694821" Lat="37814465" Avg="1" Dairy="1" Ves="1" Name="*******"/>
<data ID="77" S="2" Q="0" V="33372" V2="500" Long="-25417173" Lat="37805191" Avg="1" Dairy="1" Ves="1" Name="********"/>
<data ID="104" S="2" Q="0" V="24390" V2="500" Long="-25794643" Lat="37824955" Avg="1" Dairy="1" Ves="1" Name="******"/>
<data ID="118" S="2" Q="0" V="35149" V2="500" Long="-25833499" Lat="37857799" Avg="1" Dairy="1" Ves="1" Name="*********"/>
</suppliers>
Código de vba acess
Queria tentar adapatar o código para que consigo realizar a mesma função mas com ficheiros XML(como está referido os dados acima)
Function LeFicheiros()
Dim objFSO, objPasta, objFicheiros, objFicheiro, objTextFile, objFSOtxt As Object 'declaracao de variaveis
Dim strLinha As String
Set objFSO = CreateObject("Scripting.FileSystemObject") ' variavel de sistema tipo obj file system object
Set objPasta = objFSO.getFolder("C:\Volumes\Ficheiros") ' objpasta com a pasta dos ficheiros
Set objFicheiros = objPasta.Files ' guardar na variavel os ficheiros da pasta
For Each objFicheiro In objFicheiros ' percorre no ciclo dos ficheiros com o obj ficheiro
Set objFSOtxt = CreateObject("Scripting.FileSystemObject") ' file system object
Set objTextFile = objFSOtxt.OpenTextFile("C:\Volumes\Ficheiros" & objFicheiro.Name, 1) ' abertura do ficheiro nas posicao pretendida, com o 1 no final por defeito
Do While objTextFile.atendofstream = False ' faz enquanto não chega at end of file
strLinha = objTextFile.ReadLine 'le linha a linha e guarda na variavel
RegistaLinhas strLinha, objFicheiro.Name ' está a "apanhar" o nome do ficheiro com o . name
' funcao dos record sets, para guardar na base de dados, entra com a variavel que le linha a linha de cada vez
Loop
Set objTextFile = Nothing ' garantir que a variavel objtextfile está vazia
objFSO.MoveFile "C:\Volumes\Ficheiros" & objFicheiro.Name, "C:\Volumes\Tratados" ' mover os ficheiros integrados para a pasta tratados
Next
End Function
Function RegistaLinhas(strLinha As String, strFicheiro As String) ' nesta funcao entra o strLinha com uma string para os nomes dos ficheiros a guardar em base de dados posteriormente, não podia passar o objFicheiro.Nme
Dim rstDados As Recordset ' rstDados com o nome da tabela que se prentende guardar os registos
Set rstDados = CurrentDb().OpenRecordset("Dados", dbOpenDynaset) ' variavel definida com a base de dados atual, e entra com o nome da tabela
strDelimitado = Split(strLinha, ";")
If strDelimitado(0) = "INICIO" Or strDelimitado(0) = "FIM" Or strDelimitado(0) = "20" Then ' validar para camioes com texto de inicio ou fim para ignorar e sair da funcao
End If
rstDados.AddNew ' cria uma nova linha em branco na tabela
rstDados![Manhã] = 0
rstDados![Tarde] = 0
rstDados![Sistema] = Left(strFicheiro, InStr(strFicheiro, "_") - 1) ' para ter o nome até à posicao anterior do primeiro underscore
rstDados![Nome] = DLookup("Posto_ou_Viatura", "Sistemas", "[Sistemas] = '" & rstDados![Sistema] & "'")
rstDados![Tipo Recolha] = strDelimitado(0) ' registar dados na posicao 0, no tipo de recolha
rstDados![Data] = DateSerial(Left(strDelimitado(1), 4), Mid(strDelimitado(1), 6, 2), Right(strDelimitado(1), 2)) 'funcao para virar a data ao contrário
rstDados![Hora] = strDelimitado(2)
If rstDados![Hora] < TimeSerial(12, 0, 0) Then
rstDados![Manhã] = Replace(strDelimitado(5), ".", ",")
Else
rstDados![Tarde] = Replace(strDelimitado(5), ".", ",")
End If
rstDados![SERCLA] = strDelimitado(3)
rstDados![Número da Recolha] = strDelimitado(4)
'rstDados![Volume] = Replace(strDelimitado(5), ".", ",")
rstDados![Temperatura Amostra] = Replace(strDelimitado(6), ".", ",")
rstDados![Temperatura Mínima] = Replace(strDelimitado(7), ".", ",")
rstDados![Temperatura Média] = Replace(strDelimitado(8), ".", ",")
rstDados![Temperatura Máxima] = Replace(strDelimitado(9), ".", ",")
'If strDelimitado(10) <> "-" Then rstDados![Código Frasco] = strDelimitado(10)
rstDados![Código Inter] = strDelimitado(11)
'rstDados![Volume Estimado] = strDelimitado(12)
rstDados![Código Final Posto] = strDelimitado(13)
If Left(strFicheiro, 6) = "Camiao" Then
rstDados![Código Final Camião] = strDelimitado(14)
End If
rstDados.Update ' este update é que grava/escreve na tabela da base de dados
Set rstDados = Nothing
End Function
Se tiver outra forma de importar esse ficheiro XML para o acess agredeço a quem puder ajudar.
Reply With Quote
