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: 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
Anzeige
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. |
Neu! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
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. |