Xml-Datei laden bzw. auf Festplatte kopieren und per VBA in eine Access-Tabelle speichern

Option Compare Database
Dim strTableName As String

Sub ImportData()
    'Tabellenname definieren  
    strTableName = "Kurse"  
    With CurrentDb
        'Prüfen ob Tabelle bereits existiert  
        If DCount("[Name]", "MSysObjects", "[Name] = '" & strTableName & "'") = 1 Then  
            'Tabelle existiert, lade Updates  
            InsertNewRates "http://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml"  
        Else
            'Tabelle existiert nicht, erstelle Tabellenstruktur und lade dann die Historie  
            .Execute ("CREATE TABLE " & strTableName & " (Datum DATETIME, Währung CHAR, Kurs NUMBER);")  
            InsertNewRates "http://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist-90d.xml"  
        End If
    End With
End Sub

'Funktion die Daten aus den XML-Dateien ausliest und nur neue Daten zur Tabelle hinzufügt  
Function InsertNewRates(URL As String)
    'Eindeutiger Wert als Parameter für den Download der XML Dateien aus dem Web (Cache-Problem umgehen)  
    ticks = DateDiff("s", #1/1/1970#, Now())  
    ' XML Datei herunterladen  
    Set xmldoc = DownloadXML(URL & "?" & ticks)  
    ' war Download erfolgreich ?  
    If Not xmldoc Is Nothing Then
        'Namespaces der XML-Dateien definieren für XPath Selection  
        xmldoc.SetProperty "SelectionNamespaces", "xmlns:gesmes='http://www.gesmes.org/xml/2002-08-01' xmlns:ns='http://www.ecb.int/vocabulary/2002-08-01/eurofxref'"  
        'Alle Cube Knoten mit time property selektieren  
        Set nodes = xmldoc.SelectNodes("/gesmes:Envelope/ns:Cube/ns:Cube")  
        'Keine Knoten gefunden? => Exit  
        If nodes Is Nothing Then
           Exit Function
        End If
        ' Für jeden Datumsknoten ...  
        For Each n In nodes
            'Speichere Datum und formatiere es Datenbankgerecht  
            strDate = Format(CDate(n.Attributes.getNamedItem("time").Text), "yyyy\/mm\/dd")  
            ' Nur wenn noch keine Daten für das Datum vorhanden sind Währungen hinzufügen  
            If DCount("[Datum]", strTableName, "[Datum] = #" & strDate & "#") = 0 Then  
                'Alle Währungen zur Tabelle hinzufügen  
                For Each currencyNode In n.childNodes
                    strCurrency = Trim(currencyNode.Attributes.getNamedItem("currency").Text)  
                    strValue = Trim(currencyNode.Attributes.getNamedItem("rate").Text)  
                    CurrentDb.Execute "INSERT INTO " & strTableName & " (Datum,Währung,Kurs) VALUES(#" & strDate & "#,'" & strCurrency & "'," & strValue & ");"  
                Next
            End If
        Next
    End If
End Function

'Funktion die die XML-Dateien aus dem Web herunterlädt  
Function DownloadXML(ByVal strURL As String) As Object
    On Error GoTo Error
    Dim objhttp As Object, objXML As Object
    Set objhttp = CreateObject("Microsoft.XMLHTTP")  
    Set objXML = CreateObject("msxml2.domdocument.6.0")  
    With objhttp
        .Open "GET", strURL, False  
        .send
        If .Status = 200 Then
            Set DownloadXML = .responseXML
        Else
            Set DownloadXML = Nothing
        End If
    End With
    Exit Function
Error:
    Set DownloadXML = Nothing
End Function

Option Compare Database

'Funktion die Daten aus den XML-Dateien ausliest und nur neue Daten zur Tabelle hinzufügt  
Function ImportData()
    'Tabellenname festlegen  
    Const strTableName = "Kurse"  
    'Pfade zu den XML-Dateien angeben  
    Const XMLPATH_HISTORY = "D:\Data\eurofxref-hist.xml"  
    Const XMLPATH_DAILY = "D:\data\eurofxref-daily.xml"  
'Variablen  
    Dim xmldoc As Object, boolNewTable As Boolean, nodes As Object, n As Object, strCols As String, strValues As String, strDate As String, cName As String, currencyNode As Object
    'Objekte erstellen  
    Set xmldoc = CreateObject("Msxml2.DomDocument.6.0")  
    Set dic = CreateObject("Scripting.Dictionary")  
    With xmldoc
        .ValidateOnParse = False
        .Async = False
         'Namespaces der XML-Dateien definieren für XPath Selection  
        .SetProperty "SelectionNamespaces", "xmlns:gesmes='http://www.gesmes.org/xml/2002-08-01' xmlns:ns='http://www.ecb.int/vocabulary/2002-08-01/eurofxref'"  
        'Prüfen ob Tabelle bereits existiert  
        If DCount("[Name]", "MSysObjects", "[Name] = '" & strTableName & "'") = 1 Then  
            'Tabelle existiert  
            .Load XMLPATH_DAILY
        Else
            'Tabelle existiert nicht, erstelle Tabellenstruktur und lade dann die Historie  
            .Load XMLPATH_HISTORY
            boolNewTable = True
        End If

        'Alle Cube Knoten mit time property selektieren  
        Set nodes = xmldoc.SelectNodes("/gesmes:Envelope/ns:Cube/ns:Cube")  
        'Keine Knoten gefunden? => Exit  
        If nodes Is Nothing Then
           Exit Function
        End If
        ' Neue Tabellenstruktur erstellen  
        If boolNewTable Then
            strCols = ""  
            For Each n In nodes
                For Each currencyNode In n.childNodes
                    cName = currencyNode.Attributes.getNamedItem("currency").Text  
                    If Not dic.Exists(cName) Then
                        dic.Add cName, ""  
                        strCols = strCols & cName & " NUMBER,"  
                    End If
                Next
            Next
            strCols = Left(strCols, Len(strCols) - 1)
            CurrentDb.Execute ("CREATE TABLE " & strTableName & " (Datum DATETIME," & strCols & ");")  
            Application.RefreshDatabaseWindow
        End If
        ' Für jeden Datumsknoten ...  
        For Each n In nodes
            'Speichere Datum und formatiere es Datenbankgerecht  
            strDate = Format(CDate(n.Attributes.getNamedItem("time").Text), "yyyy\/mm\/dd")  
            ' Nur wenn noch keine Daten für das Datum vorhanden sind Währungen hinzufügen  
            If DCount("[Datum]", strTableName, "[Datum] = #" & strDate & "#") = 0 Then  
                strCols = "Datum,"  
                strValues = "#" & strDate & "#,"  
                'Alle Währungen zur Tabelle hinzufügen  
                For Each currencyNode In n.childNodes
                    strCols = strCols & Trim(currencyNode.Attributes.getNamedItem("currency").Text) & ","  
                    strValues = strValues & Trim(currencyNode.Attributes.getNamedItem("rate").Text) & ","  
                Next
                strCols = Left(strCols, Len(strCols) - 1)
                strValues = Left(strValues, Len(strValues) - 1)
                CurrentDb.Execute "INSERT INTO " & strTableName & " (" & strCols & ") VALUES(" & strValues & ");"  
            End If
        Next
    End With
End Function