Option Explicit
 
' Private Members
Private m_Sender As String
Private m_Date As Date
Private m_Count As Long
 
Private oList As Collection
 
' Benötigte API-Funktionen
Private Declare Function URLDownloadToFile Lib "urlmon" _
  Alias "URLDownloadToFileA" ( _
  ByVal pCaller As Long, _
  ByVal szURL As String, _
  ByVal szFileName As String, _
  ByVal dwReserved As Long, _
  ByVal lpfnCB As Long) As Long
 
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" _
  Alias "DeleteUrlCacheEntryA" ( _
  ByVal lpszUrlName As String) As Long
 
 
' Datei-Download mit oder ohne Leerung des URL-Cache
Private Function FileDownload(ByVal sURL As String, _
  ByVal sLocalFile As String, _
  Optional ByVal bClearCache As Boolean = True) As Boolean
 
  Dim lResult As Long
 
  ' URL-Cache leeren?
  If bClearCache Then
    lResult = DeleteUrlCacheEntry(sURL)
  End If
 
  ' Download ausführen
  Screen.MousePointer = vbHourglass
  lResult = URLDownloadToFile(0, sURL, sLocalFile, 0, 0)
  Screen.MousePointer = vbNormal
 
  FileDownload = (lResult = 0)
End Function
 
Private Sub Class_Initialize()
  ' Collection erstellen
  Set oList = New Collection
End Sub
 
Private Sub Class_Terminate()
  ' Objekte zerstören
  Set oList = Nothing
End Sub
 
' Download der XML-Datei mit den Währungskursen
' und Auslesen der Datei
Public Function ReadCurrencyRates() As Boolean
  Dim sURL As String
  Dim sFile As String
  Dim bResult As Boolean
 
  sURL = "http://www.ecb.int/stats/eurofxref/eurofxref-daily.xml"
  sFile = App.Path & "\eurofxref-daily.xml"
 
  Set oList = New Collection
  m_Count = 0
 
  If FileDownload(sURL, sFile) Then
    ' jetzt die XML-Datei auslesen
    Dim F As Integer
    Dim sData As String
    Dim sCurr As String
    Dim sBuffer As String
    Dim sLine() As String
    Dim i As Long
 
    F = FreeFile
    Open sFile For Binary As #F
    sBuffer = Space$(LOF(F))
    Get #F, , sBuffer
    Close #F
 
    sLine() = Split(sBuffer, Chr$(10))
    For i = 0 To UBound(sLine)
      sLine(i) = Trim$(Replace(sLine(i), vbTab, ""))
      If Left$(LCase$(sLine(i)), 13) = "<gesmes:name>" Then
        ' Sender
        m_Sender = XMLData(sLine(i), "gesmes:name")
      Else
        If LCase$(Left$(sLine(i), 6)) = "<cube " Then
          sLine(i) = Mid$(sLine(i), 7)
 
          If Left$(sLine(i), 5) = "time=" Then
            ' Datum/Zeit
            m_Date = CDate(XMLAttr(sLine(i), "time"))
 
          ElseIf Left$(sLine(i), 9) = "currency=" Then
            ' Währungskurs
            sCurr = XMLAttr(sLine(i), "currency")
            sData = sCurr & ";" & XMLAttr(sLine(i), "rate")
 
            oList.Add sData, sCurr
            m_Count = m_Count + 1
          End If
        End If
      End If
    Next i
    bResult = True
  End If
 
  On Error Resume Next
  Kill sFile
  On Error GoTo 0
 
  ReadCurrencyRates = bResult
End Function
 
' Hilfsfunktion
Private Function XMLData(ByVal sXML As String, ByVal sTag As String) As String
  Dim nPos As Long
  Dim sData As String
 
  nPos = InStr(1, sXML, "<" & sTag & ">", vbTextCompare)
  If nPos > 0 Then
    sData = Mid$(sXML, Len(sTag) + 3)
    nPos = InStr(1, sData, "</" & sTag & ">", vbTextCompare)
    If nPos > 0 Then
      XMLData = Left$(sData, nPos - 1)
    End If
  End If
End Function
 
' Hilfsfunktion
Private Function XMLAttr(ByVal sXML As String, ByVal sAttr As String) As String
  Dim nPos As Long
  Dim sData As String
 
  nPos = InStr(1, sXML, sAttr & "=", vbTextCompare)
  If nPos > 0 Then
    sData = Mid$(sXML, nPos + Len(sAttr) + 2)
    nPos = InStr(sData, "'")
    If nPos > 0 Then
      XMLAttr = Left$(sData, nPos - 1)
    End If
  End If
End Function
 
' Gibt das Währungskürzel zurück
Public Property Get CurrencyCode(ByVal Index As Long) As String
  Dim sData() As String
  sData = Split(oList(Index), ";")
  CurrencyCode = sData(0)
End Property
 
' Gibt den Umrechnungskurs zurück
Public Property Get CurrencyRate(ByVal IndexOrKey As Variant) As Double
  Dim sData() As String
  sData = Split(oList(IndexOrKey), ";")
  CurrencyRate = Val(sData(1))
End Property
 
' Gibt die Anzahl der vorhandenen Umrechnungskurse zurück
Public Property Get Count() As Long
  Count = m_Count
End Property
 
' Gibt den Namen des Senders zurück
Public Property Get Sender() As String
  Sender = m_Sender
End Property
 
' Gibt das Datum der Umrechnungskurse zurück
Public Property Get Time() As String
  Time = m_Date
End Property
 
' Gibt die Währungsbezeichnung zurück
Public Property Get CurrencyName(ByVal sCode As String) As Variant
  Select Case sCode
    Case "DKK": CurrencyName = "Dänemark;Danish Krone"
    Case "EUR": CurrencyName = "EU;Euro"
    Case "USD": CurrencyName = "USA;US Dollar"
    Case "GBP": CurrencyName = "Großbritannien;Pound Sterling"
    Case "SEK": CurrencyName = "Schweden;Swedish Krona"
    Case "NOK": CurrencyName = "Norwegen;Norwegian Krona"
    Case "CNY": CurrencyName = "China;Chinese Yuan Renminbi"
    Case "ISK": CurrencyName = "Island;Icelandic Krona"
    Case "IDR": CurrencyName = "Indonesien;Indonesian Rupiah"
    Case "CHF": CurrencyName = "Schweiz;Swiss franc"
    Case "CAD": CurrencyName = "Kanada;Canadian Dollar"
    Case "JPY": CurrencyName = "Japan;Japanese Yen"
    Case "RUB": CurrencyName = "Russland;Russian Rouble"
    Case "HRK": CurrencyName = "Kroatien;Croatian Kuna"
    Case "MYR": CurrencyName = "Malaysia;Malaysian Ringgit"
    Case "PHP": CurrencyName = "Philippinen;Philippine Peso"
    Case "THB": CurrencyName = "Thailand;Thai Baht"
    Case "AUD": CurrencyName = "Australien;Australian Dollar"
    Case "NZD": CurrencyName = "Neuseeland;New Zealand Dollar"
    Case "EEK": CurrencyName = "Estland;Estonian Kroon"
    Case "LVL": CurrencyName = "Lettland;Latvian Lats"
    Case "LTL": CurrencyName = "Litauen;Lithuanian Litas"
    Case "PLN": CurrencyName = "Polen;Polish Zloty"
    Case "CZK": CurrencyName = "Tschechien;Czech Koruna"
    Case "HUF": CurrencyName = "Ungarn;Hungarian Forint"
    Case "HKD": CurrencyName = "Hongkong;Hong Kong Dollar"
    Case "SGD": CurrencyName = "Singapur;Singapore Dollar"
    Case "SDR": CurrencyName = "Spezial;Special Drawing Rights"
    Case "BGN": CurrencyName = "Bulgarien;Bulgarian Lev"
    Case "CYP": CurrencyName = "Zypern;Cypriotic Pund"
    Case "MTL": CurrencyName = "Malta;Maltesic Lira"
    Case "ROL": CurrencyName = "Rumänien;Romanian Leu"
    Case "SIT": CurrencyName = "Slowenien;Slovenscy Tolar"
    Case "SKK": CurrencyName = "Slowakei;Slovakic Koruna"
    Case "TRY": CurrencyName = "Türkei;Turkish Lira"
    Case "KRW": CurrencyName = "Südkorea;South Korean Won"
    Case "ZAR": CurrencyName = "Südafrika;South African Rand"
    Case "BRL": CurrencyName = "Brasilien;Brasilian Real"
    Case "IDR": CurrencyName = "Indonesien;Indonesian Rupiah"
    Case "INR": CurrencyName = "Indien;Indian Rupee"
    Case "MXN": CurrencyName = "Mexiko;Mexican Peso"
  End Select
End Property

Dim cRate As New CurrencyRate
With cRate
  If .ReadCurrencyRates() Then
    List1.Clear
 
    Dim i As Long
    For i = 1 To .Count
      List1.AddItem .CurrencyCode(i) & " --> " & .CurrencyRate(i) & _
        " (" & .CurrencyName(.CurrencyCode(i)) & ")"
    Next i
  End If
End With
Set cRate = Nothing

_________________________
Professionelle Entwicklerkomponenten
www.tools4vb.de