vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Brandneu! sevEingabe v3.0 - Das Eingabecontrol der Superlative!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: HTML/Internet/Netzwerk · Sonstiges   |   VB-Versionen: VB629.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 OtterBewertung:     [ Jetzt bewerten ]Views:  13.060 
www.tools4vb.deSystem:  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

Dieser Tipp wurde bereits 13.060 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Aktuelle Diskussion anzeigen (3 Beiträge)

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel