Attribute VB_Name = "mdlWaehrung"
'---------------------------------------------------------------------------------------
' Modul     : mdlWaehrung
' Autor     : Klaus Oberdalhoff, Peter Doering, Thomas Möller, Jens Schilling, Günter Gerold
' Datum     : 01.03.2008
' Text      :
'---------------------------------------------------------------------------------------

Option Compare Database
Option Explicit

'---------------------------------------------------------------------------------------
' Prozedur  : getUmrechnungskursSF
' Autor     : Klaus Oberdalhoff, Peter Doering, Thomas Möller, Jens Schilling, Günter Gerold
' Datum     : 27.02.2008
' Text      :
'---------------------------------------------------------------------------------------

Public Function getUmrechnungskursAlle() As Boolean

' Legalitätscheck - Erlaubte Abfrage ...
' http://www.ecb.europa.eu/home/html/disclaimer.de.html

    Dim dtDatum As Date
    Dim abDatum As Date
    Dim strAdresse As String
    Dim strDatum As Variant
    Dim objWeb As Object
    Dim strXML As String
    Dim strDatumMarke As String
    Dim strWaehrungMarke As String
    Dim strWaehrungEndmarke As String
    Dim strLand As String
    Dim intMarkeAnfang As Integer
    Dim intLaenge As Integer
    Dim OrgWert As Currency
    Dim I As Long

    Dim DB As DAO.Database
    Dim rst As DAO.Recordset

    'Initialisieren
On Error GoTo getUmrechnungskursSF_Error
' Internetadresse mit den Kursen
strAdresse = "http://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml"

'Die Zeichenfolge mit der das Datum der Kurstabelle erkannt wird: <Cube time='2008-02-28'>
strDatumMarke = "Cube time='"
Const constDatumLaenge = 10 ' 2008-02-28

'Die Zeichenfolge mit der eine Kurszeile erkannt wird: z.B. <Cube currency='USD' rate='1.5044' />
strWaehrungMarke = "Cube currency='"
Const constLandLaenge = 3   ' USD
Const constZwischenTeilLaenge = 11  ' USD' rate='
strWaehrungEndmarke = "'/>"

If Not ObjectExists("Table", "tblUmrechnungskurs") Then
        CurrentDb.Execute ("CREATE TABLE tblUmrechnungskurs " & _
            "(UmrLand TEXT(3), CreateDate DATETIME, AbfrageDate DATETIME, UmrWert  DOUBLE, " & _
            "CONSTRAINT PrimKey PRIMARY KEY (UmrLand, CreateDate));")
End If
DoEvents
Set DB = CurrentDb
Set rst = DB.OpenRecordset("SELECT * FROM tblUmrechnungskurs;")
abDatum = Nz(rst.Fields("AbfrageDate").Value) 'wann wurde das letzte mal abgeholt?
If Not abDatum = Date Then 'nur abholen wenn heute noch nicht geschehen
    'Web-Zugriff
    Set objWeb = CreateObject("Microsoft.XMLHTTP")
    objWeb.Open "GET", strAdresse, False
    objWeb.Send
    strXML = objWeb.responseText
    strDatum = Split(Mid(strXML, InStr(strXML, strDatumMarke) + Len(strDatumMarke), constDatumLaenge), "-")
    dtDatum = DateSerial(strDatum(0), strDatum(1), strDatum(2))
    CurrentDb.Execute ("DELETE * FROM tblUmrechnungskurs WHERE CreateDate = " & _
        SQLDatum(dtDatum))
    I = 1
    Do
        intMarkeAnfang = InStr(I, strXML, strWaehrungMarke)
        If intMarkeAnfang = 0 Then Exit Do
        strLand = Mid(strXML, intMarkeAnfang + Len(strWaehrungMarke), constLandLaenge)
        intLaenge = InStr(intMarkeAnfang, strXML, strWaehrungEndmarke) - intMarkeAnfang - _
            Len(strWaehrungMarke) - constZwischenTeilLaenge
        OrgWert = CCur(Replace(Mid(strXML, intMarkeAnfang + Len(strWaehrungMarke) + constZwischenTeilLaenge, _
            intLaenge), ".", ","))
        I = intMarkeAnfang + 1  '+1 damit der erste Marker nicht zweimal gefunden wird
        With rst
            .AddNew
                rst.Fields("UmrLand").Value = strLand
                rst.Fields("CreateDate").Value = dtDatum
                rst.Fields("UmrWert").Value = OrgWert
                rst.Fields("AbfrageDate").Value = Date
            .Update
        End With
    Loop
End If
getUmrechnungskursAlle = True

Ausgang:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Set DB = Nothing
    Exit Function

getUmrechnungskursSF_Error:

 Select Case Err.Number
     Case 0
          Resume Ausgang
     Case -2146697211
          MsgBox "Im Moment leider keine Verbindung zur EZB, deshalb ist der Umrechnungskurs eventuell nicht aktuell!"
     Case Else
          getUmrechnungskursAlle = True
          Resume Ausgang
End Select

End Function


'---------------------------------------------------------------------------------------
' Prozedur  : ObjectExists
' Autor     : Klaus Oberdalhoff
' Datum     : 01.03.2008
' Text      :
'---------------------------------------------------------------------------------------

Function ObjectExists(strObjectType As String, strObjectName As String) As _
    Boolean
' Pass the Object type: Table, Query, Form, Report, Macro, or Module
' Pass the Object Name
     Dim DB As DAO.Database
     Dim tbl As DAO.TableDef
     Dim qry As DAO.QueryDef
     Dim I As Integer

     Set DB = CurrentDb()
     ObjectExists = False

     If strObjectType = "Table" Then
          For Each tbl In DB.TableDefs
               If tbl.Name = strObjectName Then
                    ObjectExists = True
                    Set DB = Nothing
                    Exit Function
               End If
          Next tbl
     ElseIf strObjectType = "Query" Then
          For Each qry In DB.QueryDefs
               If qry.Name = strObjectName Then
                    ObjectExists = True
                    Set DB = Nothing
                    Exit Function
               End If
          Next qry
     ElseIf strObjectType = "Form" Or strObjectType = "Report" Or strObjectType _
         = "Module" Then
          For I = 0 To DB.Containers(strObjectType & "s").Documents.count - 1
               If DB.Containers(strObjectType & "s").Documents(I).Name = _
                   strObjectName Then
                    ObjectExists = True
                    Set DB = Nothing
                    Exit Function
               End If
          Next I
     ElseIf strObjectType = "Macro" Then
          For I = 0 To DB.Containers("Scripts").Documents.count - 1
               If DB.Containers("Scripts").Documents(I).Name = strObjectName _
                   Then
                    ObjectExists = True
                    Set DB = Nothing
                    Exit Function
               End If
          Next I
     Else
          MsgBox _
              "Invalid Object Type passed, must be Table, Query, Form,Report, Macro, or Module"
     End If

Set DB = Nothing

End Function

'---------------------------------------------------------------------------------------
' Prozedur  : SQLDatum
' Autor     : Klaus Oberdalhoff
' Datum     : 01.03.2008
' Text      : Macht aus irgendeinem gültigen Datum einen String #yyyy-mm-dd# (ISO-Norm Datum)
'---------------------------------------------------------------------------------------

Private Function SQLDatum(Datumx) As String

If IsDate(Datumx) Then
    SQLDatum = format(CDate(Datumx), "\#yyyy\-mm\-dd\#", vbMonday, _
        vbFirstFourDays)
Else
    SQLDatum = ""
End If
End Function