Rubrik: HTML/Internet/Netzwerk · Sonstiges | VB-Versionen: VB6 | 29.09.09 |
Auslesen der aktuellen Währungskurse der ECB (European Central Bank) Die Daten der aktuellen Wechselkurse der Europäischen Zentralbank zum Euro werden aus einer XML-Datei ausgelesen und über eine VB6-Klasse bereit gestellt. | ||
Autor: Dieter Otter | Bewertung: | Views: 13.100 |
www.tools4vb.de | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Aufgrund einiger Anfragen im Forum habe ich mich entschlossen, den VB.NET Tipp Auslesen der aktuellen Währungskurse der ECB (European Central Bank) so umzuschreiben, dass der Code auch noch in älteren VB6-Projekten verwendet werden kann.
Der gesamte Code ist hierbei in einer Klasse ausgelagert. Fügen Sie Ihrem bestehenden Projekt daher zunächst ein neues Klassenmodul hinzu und benennen es CurrencyRate. In das Klassenmodul fügen Sie jetzt nachfolgenden Code ein:
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
Anmerkung:
Auf den Einsatz einer externen DLL zum Auslesen einer XML-Datei habe ich absichtlich verzichtet, da sich die heruntergeladene XML-Datei auch sehr einfach mit reinen VB6-Boardmitteln verarbeiten lässt.
Aufrufbeispiel:
' Umrechnungskurse aktualisieren Dim cRate As New CurrencyRate Screen.MousePointer = 11 With cRate If .ReadCurrencyRates() Then ' Sender und Datum anzeigen Label2.Caption = .Sender & vbCrLf & "Stand: " & .Time ListView1.ListItems.Clear Dim i As Long Dim oItem As ListItem ' Daten im ListView-Control anzeigen For i = 1 To .Count Set oItem = ListView1.ListItems.Add(, , .CurrencyCode(i)) oItem.SubItems(1) = .CurrencyRate(i) oItem.SubItems(2) = .CurrencyName(.CurrencyCode(i)) Next i End If End With Set cRate = Nothing Screen.MousePointer = 0