===========================================================
Formular frmBuchDetailansicht
===========================================================

Option Compare Database
Option Explicit

Private Sub cmdAbbildungDownloaden_Click()
    Dim strAbbildungspfad As String
    strAbbildungspfad = Anwendungspfad
    Dateidownload Me!BildKlein, strAbbildungspfad & Me!BuchID & "_klein.jpg"
    Dateidownload Me!BildMittel, strAbbildungspfad & Me!BuchID & "_mittel.jpg"
    Dateidownload Me!BildGross, strAbbildungspfad & Me!BuchID & "_gross.jpg"
    Me.Requery
End Sub

Private Sub cmdOK_Click()
    If Me!KategorieID = 0 Then
        MsgBox "Bitte whlen Sie eine Kategorie aus.", vbOKOnly + vbExclamation, "Fehlende Eingabe"
        Me!KategorieID.SetFocus
        Exit Sub
    End If
    If Me!VerlagID = 0 Then
        MsgBox "Bitte whlen Sie einen Verlag aus.", vbOKOnly + vbExclamation, "Fehlende Eingabe"
        Me!VerlagID.SetFocus
        Exit Sub
    End If
    If IstFormularGeoeffnet("frmUebersicht") Then
        Forms!frmUebersicht!lstBuecher.Requery
        Forms!frmUebersicht!cboSucheVerlage.Requery
        Forms!frmUebersicht!cboSucheAutoren.Requery
        Forms!frmUebersicht!cboSucheKategorien.Requery
    End If
    DoCmd.Close acForm, Me.Name
End Sub

Private Sub Form_Current()
    Dim strDateipfad As String
    strDateipfad = Anwendungspfad
    If Me.OpenArgs = "Uebernahme" Then
        Me!KategorieID = Me!KategorieID.ItemData(0)
    End If
    Me!ctlAbbildungKlein = Not (Dir(strDateipfad & Me!BuchID & "_klein.jpg") = "")
    Me!ctlAbbildungMittel = Not (Dir(strDateipfad & Me!BuchID & "_mittel.jpg") = "")
    Me!ctlAbbildungGross = Not (Dir(strDateipfad & Me!BuchID & "_gross.jpg") = "")
    If (Me!ctlAbbildungKlein And Me!ctlAbbildungMittel And Me!ctlAbbildungGross) Or Nz(Me!ISBN, "") = "" Then
        Me!cmdAbbildungDownloaden.Enabled = False
    Else
        Me!cmdAbbildungDownloaden.Enabled = True
    End If
    On Error GoTo Form_Current_Err
    If Dir(Anwendungspfad & Me!BuchID & "_mittel.jpg") = "" Then
        Me!picAbbildung.Picture = Anwendungspfad & "Platzhalter.jpg"
    Else
        fLoadPicture Me!picAbbildung, Anwendungspfad & Me!BuchID & "_mittel.jpg"
    End If
    On Error GoTo 0
    Exit Sub
Form_Current_Err:
    If Err.Number = 2114 Or Err.Number = 2220 Then
        Me!picAbbildung.Picture = Anwendungspfad & "Platzhalter.jpg"
        Resume Next
    End If
End Sub

Private Sub KategorieID_NotInList(NewData As String, Response As Integer)
    Response = acDataErrAdded
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Set db = CurrentDb
    Set rst = db.OpenRecordset("tblKategorien", dbOpenDynaset)
    rst.AddNew
    rst!Kategorie = NewData
    rst.Update
    rst.Close
    Set rst = Nothing
    Set db = Nothing
End Sub

Private Sub VerlagID_NotInList(NewData As String, Response As Integer)
    Response = acDataErrAdded
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Set db = CurrentDb
    Set rst = db.OpenRecordset("tblVerlage", dbOpenDynaset)
    rst.AddNew
    rst!Verlag = NewData
    rst.Update
    rst.Close
    Set rst = Nothing
    Set db = Nothing
End Sub
===========================================================
Formular frmOnlineBuchsuche
===========================================================

Option Compare Database
Option Explicit

Private Sub cboGespeicherteSuche_AfterUpdate()
    Dim strXML As String
    KriterienLoeschen
    Me!txtSuchausdruck = Me!cboGespeicherteSuche.Column(3)
    Me!txtSuchvorgangID = Me!cboGespeicherteSuche
    strXML = Nz(DLookup("XML", "tblSuchergebnisse", "SuchvorgangID = " & Me.cboGespeicherteSuche & " AND Seite = 1"), "")
    Me!txtSeite = 1
    Me!cmdSucheSpeichern.Enabled = True
    If strXML = "" Then
        Buchsuche Replace97(Me!txtSuchausdruck, " ", "%20"), Me.txtSeite
    Else
        VorhandenesSuchergebnisAnzeigen strXML
    End If
    Me!cmdSucheLoeschen.Enabled = Not (Nz(Me.cboGespeicherteSuche, 0) = 0)
    Me!cmdSucheSpeichern.Enabled = Nz(Me.cboGespeicherteSuche, 0) = 0
End Sub

Private Sub cboLanguage_NotInList(NewData As String, Response As Integer)
    MsgBox "Bitte whlen Sie einen der vorhandenen Eintrge aus.", vbOKOnly + vbExclamation, "Falsche Eingabe"
    Me!cboLanguage = Me!cboLanguage.ItemData(0)
    Me!cboLanguage.SetFocus
    Response = acDataErrContinue
End Sub

Private Sub cboPubdateFrom_BeforeUpdate(Cancel As Integer)
    SuchausdruckErstellen
End Sub

Private Sub cboPubdateTo_BeforeUpdate(Cancel As Integer)
    SuchausdruckErstellen
End Sub

Private Sub cmdKriterienLoeschen_Click()
    KriterienLoeschen
End Sub

Private Sub KriterienLoeschen()
    Me!txtAuthor = Null
    Me!txtISBN = Null
    Me!txtKeywords = Null
    Me!txtPublisher = Null
    Me!txtTitle = Null
    Me!cboLanguage = Null
    Me!cboPubdateFrom = Null
    Me!cboPubdateTo = Null
    Me!txtSuchausdruck = Null
End Sub

Private Sub cmdSchliessen_Click()
    DoCmd.Close acForm, Me.Name
End Sub

Public Sub Buchsuche(strSuchausdruck As String, intSeite As Integer)
    Dim objXMLDocument As New MSXML2.DOMDocument
    'Neu 8.6.2004 Start
    Dim objXMLErrorMessage As Object
    'Neu 8.6.2004 Ende
    Dim strAnfrage As String
    Dim AssociatesID As String
    Dim DeveloperToken As String
    Dim bolSuccess As Boolean
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim strSprache As String
    strSprache = IIf(Me!cboLanguage = "Englisch", "books-de-intl-us", _
        "books-de")
    AssociatesID = "webservices-20"
    DeveloperToken = "D1SRGUPDHPA31V"
    strAnfrage = "http://xml-eu.amazon.com/onca/xml3?t=" & AssociatesID _
        & "&dev-t=" & DeveloperToken & "&PowerSearch=" & strSuchausdruck _
        & "&page=" & intSeite & "&mode=" & strSprache _
        & "&type=heavy&f=xml&locale=de&sort=" & Me!cboSortierung
    With objXMLDocument
        .async = False
        .preserveWhiteSpace = False
        .validateOnParse = True
        .resolveExternals = False
    End With
    bolSuccess = objXMLDocument.Load(strAnfrage)
    If bolSuccess = True Then
        Set db = CurrentDb
        Set rst = db.OpenRecordset("SELECT * FROM tblSuchergebnisse " _
            & "WHERE SuchergebnisID = 0", dbOpenDynaset)
        rst.AddNew
        rst!SuchvorgangID = Me!txtSuchvorgangID
        rst!Seite = intSeite
        rst!xml = objXMLDocument.xml
        rst.Update
        objXMLDocument.Save Anwendungspfad & "Suchergebnis.xml"
        SuchergebnisAuswerten objXMLDocument
        Me.lstSuchergebnis.Requery
        Me!cmdSucheStarten.SetFocus
        Me!cmdWeitereZehn.Enabled = (intSeite < CLng(Me!txtAnzahlSeiten))
        Me!cmdVorherigeZehn.Enabled = (intSeite > 1)
    Else
        MsgBox "Fehler!" & vbCrLf & objXMLDocument.parseError.reason
    End If
End Sub

Private Sub VorhandenesSuchergebnisAnzeigen(strXML As String)
    Dim objXMLDocument As New MSXML2.DOMDocument
    With objXMLDocument
        .async = False
        .preserveWhiteSpace = False
        .validateOnParse = True
        .resolveExternals = False
    End With
    objXMLDocument.loadXML CStr(strXML)
    SuchergebnisAuswerten objXMLDocument
    Me.lstSuchergebnis.Requery
    Me.cmdSucheSpeichern.SetFocus
    Me!cmdWeitereZehn.Enabled = (Me.txtSeite < CLng(Me!txtAnzahlSeiten))
    Me!cmdVorherigeZehn.Enabled = (Me.txtSeite > 1)
End Sub

Private Function BuchdetailsErmitteln(objXMLBuch As Object) As Buchdetails
    Dim objBuchdetails As Buchdetails
    Dim objXMLAsin As Object
    Dim objXMLTitle As Object
    Dim objXMLListprice As Object
    Dim objXMLOurPrice As Object
    Dim objXMLManufacturer As Object
    Dim objXMLAuthors As Object
    Dim objXMLReleaseDate As Object
    Dim objXMLURLSmall As Object
    Dim objXMLURLMedium As Object
    Dim objXMLURLLarge As Object
    Dim objXMLAuthor As Object
    Dim i As Integer
    Set objXMLAsin = objXMLBuch.selectSingleNode("Asin")
    Set objXMLTitle = objXMLBuch.selectSingleNode("ProductName")
    Set objXMLListprice = objXMLBuch.selectSingleNode("ListPrice")
    Set objXMLOurPrice = objXMLBuch.selectSingleNode("OurPrice")
    Set objXMLManufacturer = objXMLBuch.selectSingleNode("Manufacturer")
    Set objXMLAuthors = objXMLBuch.selectSingleNode("Authors")
    Set objXMLReleaseDate = objXMLBuch.selectSingleNode("ReleaseDate")
    Set objXMLURLSmall = objXMLBuch.selectSingleNode("ImageUrlSmall")
    Set objXMLURLMedium = objXMLBuch.selectSingleNode("ImageUrlMedium")
    Set objXMLURLLarge = objXMLBuch.selectSingleNode("ImageUrlLarge")
    If (Not (objXMLAsin Is Nothing)) Then objBuchdetails.ISBN = objXMLAsin.Text
    If (Not (objXMLTitle Is Nothing)) Then objBuchdetails.Title = objXMLTitle.Text
    If (Not (objXMLListprice Is Nothing)) Then objBuchdetails.Listenpreis = objXMLListprice.Text
    If (Not (objXMLOurPrice Is Nothing)) Then objBuchdetails.UnserPreis = objXMLOurPrice.Text
    If (Not (objXMLManufacturer Is Nothing)) Then objBuchdetails.Verlag = objXMLManufacturer.Text
    If (Not (objXMLReleaseDate Is Nothing)) Then objBuchdetails.Erscheinungsdatum = objXMLReleaseDate.Text
    If (Not (objXMLURLSmall Is Nothing)) Then objBuchdetails.BildKlein = objXMLURLSmall.Text
    If (Not (objXMLURLMedium Is Nothing)) Then objBuchdetails.BildMittel = objXMLURLMedium.Text
    If (Not (objXMLURLLarge Is Nothing)) Then objBuchdetails.BildGross = objXMLURLLarge.Text
    objBuchdetails.URL = objXMLBuch.getAttribute("url")
    If (Not (objXMLAuthors Is Nothing)) Then
        For i = 0 To objXMLAuthors.childNodes.Length - 1
            Set objXMLAuthor = objXMLAuthors.childNodes.Item(i)
            ReDim Preserve objBuchdetails.Autoren(i + 1)
            objBuchdetails.Autoren(i + 1) = MehrfacheLeerzeichenEntfernen(objXMLAuthor.Text)
        Next i
    Else
        ReDim objBuchdetails.Autoren(1)
    End If
    BuchdetailsErmitteln = objBuchdetails
End Function

Private Function SuchergebnisAuswerten(objXMLDocument As MSXML2.DOMDocument) _
    As String
    Dim i As Integer
    Dim j As Integer
    Dim objXMLRoot As Object
    Dim objXMLChild As Object
    Dim objBuchdetails As Buchdetails
    Dim strSuchergebnis As String
    Dim strAutoren As String
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Set db = CurrentDb
    db.Execute "DELETE FROM tblBuecherTemp"
    Set rst = db.OpenRecordset("tblBuecherTemp", dbOpenDynaset)
    Me!txtAnzahlErgebnisse = 0
    Me!txtAnzahlSeiten = 0
    Set objXMLRoot = objXMLDocument.documentElement
    For i = 0 To objXMLRoot.childNodes.Length - 1
        Set objXMLChild = objXMLRoot.childNodes.Item(i)
        Select Case objXMLChild.nodeName
            Case "TotalResults"
                Me.txtAnzahlErgebnisse = objXMLChild.Text
            Case "TotalPages"
                Me.txtAnzahlSeiten = objXMLChild.Text
            Case "Details"
                objBuchdetails = BuchdetailsErmitteln(objXMLChild)
                With objBuchdetails
                    strAutoren = ""
                    For j = 1 To UBound(.Autoren)
                        strAutoren = strAutoren & .Autoren(j) & ", "
                    Next j
                    If Len(strAutoren) > 0 Then
                        strAutoren = Left(strAutoren, Len(strAutoren) - 2)
                    End If
                    rst.AddNew
                    rst!ISBN = .ISBN
                    rst!Titel = .Title
                    rst!Verlag = .Verlag
                    rst!Jahr = .Erscheinungsdatum
                    rst!Autor = strAutoren
                    rst!Preis = .UnserPreis
                    rst!URL = .URL
                    rst.Update
                End With
        End Select
    Next i
End Function

Private Sub cmdSucheSpeichern_Click()
    Dim strSucheName As String
    Dim db As DAO.Database
    Set db = CurrentDb
    strSucheName = InputBox("Geben Sie einen Namen fr die Suche ein.")
    If Nz(strSucheName, "") = "" Then
        Exit Sub
    Else
        If Not IsNull(DLookup("Bezeichnung", "tblSuchvorgaenge", "Bezeichnung = '" & strSucheName & "'")) Then
            MsgBox "Die Bezeichnung ist bereits vorhanden.", vbOKOnly
            Exit Sub
        Else
            db.Execute "UPDATE tblSuchvorgaenge SET Bezeichnung = '" & strSucheName & "' WHERE SuchvorgangID = " & Me!txtSuchvorgangID
            Me!cboGespeicherteSuche.Requery
        End If
    End If
    Set db = Nothing
End Sub

Private Sub cmdSucheStarten_Click()
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    DoCmd.Hourglass True
    If Nz(Me!txtSuchausdruck, "") = "" Then
        MsgBox "Bitte geben Sie einen Suchausdruck ein.", vbOKOnly + _
            vbExclamation, "Bcher suchen"
    Else
        Set db = CurrentDb
        db.Execute "DELETE * FROM tblSuchvorgaenge WHERE Bezeichnung = 'temp'"
        Set rst = db.OpenRecordset("SELECT * FROM tblSuchvorgaenge " _
            & "WHERE SuchvorgangID = 0", dbOpenDynaset)
        rst.AddNew
        rst!Bezeichnung = "temp"
        rst!Datum = Date
        rst!Suchausdruck = Me!txtSuchausdruck
        Me!txtSuchvorgangID = rst!SuchvorgangID
        rst.Update
        Me!cmdSucheSpeichern.Enabled = True
        Me!txtSeite = 1
        Buchsuche Replace97(Me!txtSuchausdruck, " ", "%20"), Me!txtSeite
        If Me!txtAnzahlSeiten = 0 Then
            Me!txtSeite = 0
            Me.cmdTitelUebernehmen.Enabled = False
        End If
    End If
    DoCmd.Hourglass False
End Sub

Private Sub cmdTitelBestellen_Click()
    Application.FollowHyperlink Me.lstSuchergebnis.Column(6)
End Sub

Private Sub cmdTitelUebernehmen_Click()
    Dim intBuchID
    If Nz(Me.lstSuchergebnis, 0) = 0 Then
        MsgBox "Bitte whlen Sie zunchst den zu bernehmenden Titel aus.", vbOKOnly + vbExclamation, "Bcherverwaltung"
        Exit Sub
    End If
    intBuchID = BuchSpeichern(Me.lstSuchergebnis)
    If Not intBuchID = 0 Then
        DoCmd.OpenForm "frmBuchDetailansicht", WhereCondition:="BuchID = " & intBuchID, DataMode:=acFormEdit, OpenArgs:="Uebernahme"
    End If
End Sub

Private Function BuchSpeichern(ISBN As String)
    Dim db As DAO.Database
    Dim rstVerlage As DAO.Recordset
    Dim rstBuecher As DAO.Recordset
    Dim rstAutoren As DAO.Recordset
    Dim objXMLDocument As New MSXML2.DOMDocument
    Dim objXMLBuch As Object
    Dim objBuchdetails As Buchdetails
    Dim strXML As String
    Dim intBuchID As Integer
    Dim intVerlagID As Integer
    Dim intAutorID As Integer
    Dim i As Integer
    strXML = DLookup("XML", "tblSuchergebnisse", "SuchvorgangID = " _
        & Me!txtSuchvorgangID & " AND Seite = " & Me.txtSeite)
    objXMLDocument.loadXML strXML
    Set objXMLBuch = _
        objXMLDocument.selectSingleNode("//Details[Asin = '" & ISBN & "']")
    objBuchdetails = BuchdetailsErmitteln(objXMLBuch)
    Set db = CurrentDb
    Set rstVerlage = db.OpenRecordset("tblVerlage", dbOpenDynaset)
    With rstVerlage
        .FindFirst "Verlag = '" & objBuchdetails.Verlag & "'"
        If .NoMatch Then
            .AddNew
            !Verlag = objBuchdetails.Verlag
            intVerlagID = !VerlagID
            .Update
        Else
            intVerlagID = !VerlagID
        End If
        .Close
    End With
    Set rstBuecher = db.OpenRecordset("tblBuecher", dbOpenDynaset)
    With rstBuecher
        .FindFirst "ISBN = '" & objBuchdetails.ISBN & "'"
        If Not .NoMatch Then
            If MsgBox("Es ist bereits ein Buch mit dieser ISBN vorhanden. " _
                & "Sollen die vorhandenen Daten berschrieben werden?", _
                vbYesNo + vbExclamation, "Bcherverwaltung") = vbNo Then
                BuchSpeichern = 0
                Exit Function
            End If
            .Edit
        Else
            .AddNew
        End If
        !Titel = objBuchdetails.Title
        !ISBN = objBuchdetails.ISBN
        !Erscheinungsdatum = objBuchdetails.Erscheinungsdatum
        !VerlagID = intVerlagID
        !BildKlein = objBuchdetails.BildKlein
        !BildMittel = objBuchdetails.BildMittel
        !BildGross = objBuchdetails.BildGross
        !URL = objBuchdetails.URL
        intBuchID = !BuchID
        .Update
        .Close
    End With
    Set rstAutoren = db.OpenRecordset("tblAutoren", dbOpenDynaset)
    With rstAutoren
        For i = 1 To UBound(objBuchdetails.Autoren)
            .FindFirst "Autor = '" & objBuchdetails.Autoren(i) & "'"
            If .NoMatch Then
               .AddNew
               !Autor = objBuchdetails.Autoren(i)
               intAutorID = !AutorID
               .Update
            Else
                intAutorID = !AutorID
            End If
            On Error Resume Next
            db.Execute "INSERT INTO tblBuecherAutoren(BuchID, AutorID) " _
                & "VALUES(" & intBuchID & ", " & intAutorID & ")"
        Next i
        .Close
    End With
    Set rstAutoren = Nothing
    Set rstBuecher = Nothing
    Set rstVerlage = Nothing
    Set db = Nothing
    BuchSpeichern = intBuchID
End Function

Private Sub cmdVorherigeZehn_Click()
    Dim strXML As String
    strXML = Nz(DLookup("XML", "tblSuchergebnisse", "SuchvorgangID = " & Me!txtSuchvorgangID & " AND Seite = " & Me!txtSeite - 1), "")
    Me!txtSeite = Me!txtSeite - 1
    If strXML = "" Then
        Buchsuche Replace97(Me!txtSuchausdruck, " ", "%20"), Me.txtSeite
    Else
        VorhandenesSuchergebnisAnzeigen strXML
    End If
End Sub

Private Sub cmdWeitereZehn_Click()
    Dim strXML As String
    strXML = Nz(DLookup("XML", "tblSuchergebnisse", "SuchvorgangID = " & Me!txtSuchvorgangID & " AND Seite = " & Me!txtSeite + 1), "")
    Me!txtSeite = Me!txtSeite + 1
    If strXML = "" Then
        Buchsuche Replace97(Me!txtSuchausdruck, " ", "%20"), Me!txtSeite
    Else
        VorhandenesSuchergebnisAnzeigen strXML
    End If
End Sub

Private Sub Form_Current()
    'Me!lstSuchergebnis.RowSource = ""
    
    Me!txtSeite = 0
    Me!txtAnzahlSeiten = 0
    Me!txtAnzahlErgebnisse = 0
    Me!cmdTitelUebernehmen.Enabled = False
    Me!cmdVorherigeZehn.Enabled = False
    Me!cmdWeitereZehn.Enabled = False
    Me.cmdSucheSpeichern.Enabled = False
    Me!cboSortierung = Me!cboSortierung.ItemData(0)
    Me!cboLanguage = Me!cboLanguage.ItemData(0)
End Sub


Private Sub lstSuchergebnis_AfterUpdate()
    If IsNull(Me!lstSuchergebnis) Then
        Me!cmdTitelUebernehmen.Enabled = False
        Me!cmdTitelBestellen.Enabled = False
    Else
        Me!cmdTitelUebernehmen.Enabled = True
        Me!cmdTitelBestellen.Enabled = True
    End If
End Sub

Private Sub txtAuthor_AfterUpdate()
    SuchausdruckErstellen
End Sub

Private Sub txtISBN_BeforeUpdate(Cancel As Integer)
    SuchausdruckErstellen
End Sub

Private Sub txtKeywords_BeforeUpdate(Cancel As Integer)
    SuchausdruckErstellen
End Sub

Private Sub txtPublisher_BeforeUpdate(Cancel As Integer)
    SuchausdruckErstellen
End Sub

Private Sub txtTitle_AfterUpdate()
    SuchausdruckErstellen
End Sub

Private Sub SuchausdruckErstellen()
    Dim i As Integer
    Dim strSuchausdruck As String
    Dim strErscheinungsjahr As String
    If Not Nz(Me!txtTitle, "") = "" Then
        strSuchausdruck = strSuchausdruck & " and title:" & Me!txtTitle
    End If
    If Not Nz(Me!txtAuthor, "") = "" Then
        strSuchausdruck = strSuchausdruck & " and author:" & Me!txtAuthor
    End If
    If Not Nz(Me!txtISBN, "") = "" Then
        strSuchausdruck = strSuchausdruck & " and isbn:" & Me!txtISBN
    End If
    If Not Nz(Me!txtKeywords, "") = "" Then
        strSuchausdruck = strSuchausdruck & " and keywords:" & Me!txtKeywords
    End If
    If Not Nz(Me!txtPublisher, "") = "" Then
        strSuchausdruck = strSuchausdruck & " and publisher:" & Me!txtPublisher
    End If
    If Not Me!cboPubdateFrom = 0 Then
        strErscheinungsjahr = strErscheinungsjahr & " pubdate:" & Me!cboPubdateFrom
        If Not Me.cboPubdateTo = 0 Then
            strErscheinungsjahr = ""
            For i = Me!cboPubdateFrom To Me!cboPubdateTo Step IIf(Me!cboPubdateFrom <= Me!cboPubdateTo, 1, -1)
                strErscheinungsjahr = strErscheinungsjahr & " or pubdate:" & i
            Next i
        Else
        End If
    End If
    If Len(strErscheinungsjahr) > 0 Then
        strSuchausdruck = strSuchausdruck & " and (" & Mid(strErscheinungsjahr, 5) & ")"
    End If
    Me!cmdSucheSpeichern.Enabled = False
    Me!txtSuchausdruck = Mid(Trim(strSuchausdruck), 5)
End Sub
===========================================================
Formular frmStart
===========================================================

Option Compare Database
Option Explicit

Private Sub cmdStart_Click()
    DoCmd.OpenForm "frmUebersicht"
    DoCmd.Close acForm, Me.Name
End Sub
===========================================================
Formular frmUebersicht
===========================================================

Option Compare Database
Option Explicit

Private Sub cboSucheAutoren_NotInList(NewData As String, Response As Integer)
    Response = acDataErrDisplay
End Sub

Private Sub cmdAmazon_Click()
    Dim db As DAO.Database
    Set db = CurrentDb
    db.Execute "DELETE FROM tblBuecherTemp"
    Set db = Nothing
    DoCmd.OpenForm "frmOnlineBuchsuche"
End Sub

Private Sub cmdBeenden_Click()
    DoCmd.Quit
End Sub

Private Sub cmdBestellen_Click()
    Application.FollowHyperlink Me!lstBuecher.Column(6)
End Sub

Private Sub cmdBuchAnlegen_Click()
    If Not IsNull(Me!lstBuecher) Then
        DoCmd.OpenForm "frmBuchDetailansicht", WindowMode:=acDialog, WhereCondition:="BuchID = " & Me!lstBuecher, DataMode:=acFormEdit
    End If
    Me!lstBuecher.Requery
End Sub

Private Sub cmdDetailansicht_Click()
    DoCmd.OpenForm "frmBuchdetailansicht", DataMode:=acFormEdit, WindowMode:=acDialog
    Me!lstBuecher.Requery
End Sub

Private Sub cmdKriterienLoeschen_Click()
    Me!txtSucheBemerkungen = Null
    Me!txtSucheTitel = Null
    Me!cboSucheAutoren = ""
    Me!txtSucheErscheinungsjahr = Null
    Me!cboSucheKategorien = ""
    Me!cboSucheVerlage = ""
    Me!lstBuecher.RowSource = "qryBuchsuche"
End Sub

Private Sub cmdListeAusgeben_Click()
    Dim strSQLBedingung As String
    strSQLBedingung = SQLBedingung
    If DCount("BuchID", "qryBuchsuche", strSQLBedingung) > 0 Then
        DoCmd.OpenReport "rptBuchliste", View:=acViewPreview, WhereCondition:=strSQLBedingung
    Else
        MsgBox "Es sind keine Daten zur Ausgabe vorhanden.", vbOKOnly + vbExclamation, "Keine Daten"
    End If
End Sub

Private Sub cmdLoeschen_Click()
    Dim db As DAO.Database
    On Error GoTo cmdLoeschen_Click_Err
    If IsNull(Me!lstBuecher) Then
        MsgBox "Bitte whlen Sie zunchst den zu lschenden Eintrag aus.", vbOKOnly + vbExclamation, "Bcherverwaltung"
        Exit Sub
    End If
    Set db = CurrentDb
    If MsgBox("Mchten Sie das markierte Buch wirklich aus der Datenbank lschen? Eventuell zu diesem Buch gehrende Abbildungen werden ebenfalls gelscht.", vbYesNo, "Bcherverwaltung") = vbYes Then
        On Error Resume Next
        Kill Anwendungspfad & Me.lstBuecher.Column(0) & "*"
        On Error GoTo cmdLoeschen_Click_Err
        db.Execute "DELETE FROM tblBuecher WHERE BuchID = " & Me!lstBuecher, dbfailonerror
    End If
    Me!lstBuecher.Requery
    Me!cmdBuchAnlegen.SetFocus
    Me!cmdLoeschen.Enabled = False
    Me!cmdDetailansicht.Enabled = False
    Me!cmdBestellen.Enabled = False
    Set db = Nothing
    Exit Sub
cmdLoeschen_Click_Err:
    Debug.Print Err.Number, Err.Description
End Sub

Private Function SQLBedingung()
    Dim strSQLBedingung As String
    If Not Nz(Me!txtSucheBemerkungen, "") = "" Then
        strSQLBedingung = strSQLBedingung & " AND Bemerkungen LIKE '*" & Me!txtSucheBemerkungen & "*'"
    End If
    If Not Nz(Me!txtSucheErscheinungsjahr, "") = "" Then
        strSQLBedingung = strSQLBedingung & " AND Erscheinungsdatum LIKE '*" & Me!txtSucheErscheinungsjahr & "*'"
    End If
    If Not Nz(Me!txtSucheTitel, "") = "" Then
        strSQLBedingung = strSQLBedingung & " AND Titel LIKE '*" & Me!txtSucheTitel & "*'"
    End If
    If Not Nz(Me!cboSucheAutoren, 0) = 0 Then
        strSQLBedingung = strSQLBedingung & " AND AutorenTemp LIKE '*" & Me!cboSucheAutoren & "*'"
    End If
    If Not Nz(Me!cboSucheKategorien, 0) = 0 Then
        strSQLBedingung = strSQLBedingung & " AND Kategorie LIKE '*" & Me.cboSucheKategorien & "*'"
    End If
    If Not Nz(Me!cboSucheVerlage, 0) = 0 Then
        strSQLBedingung = strSQLBedingung & " AND Verlag LIKE '*" & Me.cboSucheVerlage & "*'"
    End If
    SQLBedingung = Mid(strSQLBedingung, 5)
End Function

Private Sub cmdSuche_Click()
    Dim strSQLBasis As String
    Dim strSQLBedingung As String
    Dim strSQL As String
    strSQLBasis = "SELECT * FROM qryBuchsuche"
    strSQLBedingung = SQLBedingung
    If Not Len(strSQLBedingung) = 0 Then
        strSQLBedingung = " WHERE " & strSQLBedingung
    End If
    strSQL = strSQLBasis & strSQLBedingung
    Me!lstBuecher.RowSource = strSQL
    Me!lstBuecher.Requery
End Sub

Private Sub Form_Current()
    Me!lstBuecher.Requery
    Me!cmdLoeschen.Enabled = False
    Me!cmdDetailansicht.Enabled = False
    Me!cmdBestellen.Enabled = False
End Sub

Private Sub lstBuecher_AfterUpdate()
    Me!cmdBestellen.Enabled = True
    Me!cmdLoeschen.Enabled = True
    Me!cmdDetailansicht.Enabled = True
End Sub

Private Sub lstBuecher_DblClick(Cancel As Integer)
    If Not IsNull(Me!lstBuecher) Then
        DoCmd.OpenForm "frmBuchDetailansicht", WindowMode:=acDialog, WhereCondition:="BuchID = " & Me!lstBuecher, DataMode:=acFormEdit
    End If
End Sub
===========================================================
Formular sfmAutoren
===========================================================

Option Compare Database
Option Explicit

Private Sub AutorID_NotInList(NewData As String, Response As Integer)
    Response = acDataErrAdded
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Set db = CurrentDb
    Set rst = db.OpenRecordset("tblAutoren", dbOpenDynaset)
    rst.AddNew
    rst!Autor = NewData
    rst.Update
    rst.Close
    Set rst = Nothing
    Set db = Nothing
End Sub

Private Sub Form_AfterUpdate()
    AutorenAktualisieren
End Sub

Private Sub AutorenAktualisieren()
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim strAutoren As String
    If Not Me.Parent.NewRecord Then
        Set db = CurrentDb
        Set rst = Me.RecordsetClone
        If Not rst.RecordCount = 0 Then
            rst.MoveFirst
            Do While Not rst.EOF
                strAutoren = strAutoren & rst!Autor & ", "
                rst.MoveNext
            Loop
            If Len(strAutoren) > 0 Then
                strAutoren = Left(strAutoren, Len(strAutoren) - 2)
            End If
            strAutoren = Replace97(strAutoren, "'", "''")
            db.Execute "UPDATE tblBuecher SET AutorenTemp = '" & strAutoren & "' WHERE BuchID = " & Me.Parent!BuchID
            rst.Close
        End If
        Set rst = Nothing
        Set db = Nothing
    End If
End Sub

Private Sub Form_Current()
    AutorenAktualisieren
End Sub

Private Sub Form_Error(DataErr As Integer, Response As Integer)
    If DataErr = 3058 Then
        MsgBox "Bitte geben Sie ISBN oder Titel ein, bevor Sie den oder die Autoren eingeben.", vbOKOnly + vbExclamation, "Bcherverwaltung"
        Me.Undo
        Response = acDataErrContinue
    End If
End Sub
===========================================================
Formular sfmBuecherListe
===========================================================

Option Compare Database
Option Explicit

Private Sub Form_Current()
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim strAutoren As String
    Set db = CurrentDb
    Set rst = db.OpenRecordset("SELECT Autor FROM tblAutoren INNER JOIN tblBuecherAutoren ON tblAutoren.AutorID = tblBuecherAutoren.AutorID WHERE tblBuecherAutoren.BuchID = " & Nz(Me!BuchID, 0), dbOpenDynaset)
    Do While Not rst.EOF
        strAutoren = strAutoren & ", " & rst!Autor
        rst.MoveNext
    Loop
    If Not Len(strAutoren) = 0 Then
        strAutoren = Left(strAutoren, Len(strAutoren) - 2)
    End If
    Me!txtAutoren = strAutoren
    rst.Close
    Set rst = Nothing
    Set db = Nothing
End Sub
===========================================================
Bericht rptBuchliste
===========================================================

Option Compare Database
Option Explicit

Private Sub Detailbereich_Print(Cancel As Integer, PrintCount As Integer)
    Dim strBildpfad As String
    strBildpfad = Anwendungspfad
    On Error GoTo Detailbereich_Print_Err
    If Not Dir(strBildpfad & Me!BuchID & "_mittel.jpg") = "" Then
        fLoadPicture Me!picAbbildung, strBildpfad & Me!BuchID & "_mittel.jpg"
    Else
        Me!picAbbildung.Picture = strBildpfad & "Platzhalter.jpg"
    End If
    Exit Sub
Detailbereich_Print_Err:
    If Err.Number = 2114 Then
        Me!picAbbildung.Picture = strBildpfad & "Platzhalter.jpg"
    End If
End Sub
===========================================================
Modul mdlGlobal
===========================================================
Option Compare Database
Option Explicit

Public Type Buchdetails
    Title As String
    ISBN As String
    Listenpreis As String
    UnserPreis As String
    Erscheinungsdatum As String
    Autoren() As String
    Verlag As String
    URL As String
    BildKlein As String
    BildMittel As String
    BildGross As String
End Type

===========================================================
Modul mdlJPEG
===========================================================
Option Compare Database

Private Type POINTAPI
    x As Long
    y As Long
End Type

Public Type RECTL
    Left As Long
    top As Long
    right As Long
    Bottom As Long
End Type

Private Type SIZEL
    cx As Long
    cy As Long
End Type

Private Const BLACKONWHITE = 1
Private Const WHITEONBLACK = 2
Private Const COLORONCOLOR = 3
Private Const HALFTONE = 4
Private Const MAXSTRETCHBLTMODE = 4
Private Const WM_HSCROLL = &H114
Private Const WM_VSCROLL = &H115
Private Const SB_LINEUP = 0
Private Const SB_LINELEFT = 0
Private Const SB_LINEDOWN = 1
Private Const SB_LINERIGHT = 1
Private Const SB_PAGEUP = 2
Private Const SB_PAGELEFT = 2
Private Const SB_PAGEDOWN = 3
Private Const SB_PAGERIGHT = 3
Private Const SB_THUMBPOSITION = 4
Private Const SB_THUMBTRACK = 5
Private Const SB_TOP = 6
Private Const SB_LEFT = 6
Private Const SB_BOTTOM = 7
Private Const SB_RIGHT = 7
Private Const SB_ENDSCROLL = 8
Private Const SRCCOPY = &HCC0020
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14
Private Const MM_TEXT = 1
Private Const MM_LOMETRIC = 2
Private Const MM_HIMETRIC = 3
Private Const MM_LOENGLISH = 4
Private Const MM_HIENGLISH = 5
Private Const MM_TWIPS = 6
Private Const MM_ISOTROPIC = 7
Private Const MM_ANISOTROPIC = 8
Private Const vbPicTypeNone = 0
Private Const vbPicTypeBitmap = 1
Private Const vbPicTypeMetafile = 2
Private Const vbPicTypeIcon = 3
Private Const vbPicTypeEMetafile = 4
Private Const WHITE_BRUSH = 0
Private Const LTGRAY_BRUSH = 1
Private Const GRAY_BRUSH = 2
Private Const DKGRAY_BRUSH = 3
Private Const BLACK_BRUSH = 4
Private Const NULL_BRUSH = 5
Private Const HOLLOW_BRUSH = NULL_BRUSH
Private Const WHITE_PEN = 6
Private Const BLACK_PEN = 7
Private Const NULL_PEN = 8
Private Const OEM_FIXED_FONT = 10
Private Const ANSI_FIXED_FONT = 11
Private Const ANSI_VAR_FONT = 12
Private Const SYSTEM_FONT = 13
Private Const DEVICE_DEFAULT_FONT = 14
Private Const DEFAULT_PALETTE = 15
Private Const SYSTEM_FIXED_FONT = 16
Private Const STOCK_LAST = 16
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const BKMODE_LAST = 2
Private Const HORZSIZE = 4
Private Const VERTSIZE = 6
Private Const HORZRES = 8
Private Const VERTRES = 10
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const TWIPSPERINCH = 1440

Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hDC As Long, ByVal nMapMode As Long) As Long
Private Declare Function SetWindowExtEx Lib "gdi32" (ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, lpSize As SIZEL) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function apiGetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As Long
Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetEnhMetaFileBits Lib "gdi32" (ByVal hEMF As Long, ByVal cbBuffer As Long, lpbBuffer As Byte) As Long
Private Declare Function apiCreateEnhMetaFileRECT Lib "gdi32" Alias "CreateEnhMetaFileA" (ByVal hDCref As Long, ByVal lpFileName As String, ByRef lpRect As RECTL, ByVal lpDescription As String) As Long
Private Declare Function SetWindowOrgEx Lib "gdi32" (ByVal hDC As Long, ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI) As Long
Private Declare Function apiSelectObject Lib "gdi32" Alias "SelectObject" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function apiCloseEnhMetaFile Lib "gdi32" Alias "CloseEnhMetaFile" (ByVal hDC As Long) As Long
Private Declare Function apiDeleteEnhMetaFile Lib "gdi32" Alias "DeleteEnhMetaFile" (ByVal hEMF As Long) As Long
Private Declare Function apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hWnd As Long, ByVal hDC As Long) As Long

'Copyright: Lebans Holding 1999 Ltd. http://www.lebans.com
Public Function fLoadPicture(ctl As Access.Image, strfName As String, Optional AutoSize As Boolean = False) As Boolean
    On Error GoTo Err_fLoadPicture
    Dim lngRet As Long
    Dim blRet As Boolean
    Dim hPic As Object
    Application.Screen.MousePointer = 11
    Select Case right$(strfName, 3)
        Case "bmp", "dib", "Gif", "emf", "Wmf", "ico", "cur", "jpg"
            Set hPic = LoadPicture(strfName)
        Case Else
            Err.Raise vbObjectError + 518, "LoadJpegGif.modStdPic", _
                "This Image format is not supported!" & vbCrLf & strfName & vbCrLf & _
                "Please Select a Supported Image format:" & vbCrLf & _
                "JPEG, TIFF, PNG, BMP, DIB, GIF, EMF, WMF, ICO or CUR"
    End Select
    If hPic = 0 Then
        Err.Raise vbObjectError + 514, "LoadJpegGif.modStdPic", _
            "Please Select a Supported Image format:" & vbCrLf & _
            "JPEG, TIFF, PNG, BMP, DIB, GIF, EMF, WMF, ICO or CUR"
    End If
    blRet = fStdPicToImageData(hPic, ctl, , AutoSize)
    fLoadPicture = True
Exit_LoadPic:
    Application.Echo True
    Application.Screen.MousePointer = 0
    Err.Clear
    Set hPic = Nothing
    Set clsDialog = Nothing
    Exit Function
Err_fLoadPicture:
    fLoadPicture = False
    Application.Screen.MousePointer = 0
    MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
    Resume Exit_LoadPic
End Function

'Copyright: Lebans Holding 1999 Ltd. http://www.lebans.com
Function fStdPicToImageData(hStdPic As Object, ctl As Access.Image, Optional FileNamePath As String = "", Optional AutoSize As Boolean = False) As Boolean
    On Error GoTo ERR_SHOWPIC
    Dim hDCref As Long
    Dim sz As SIZEL
    Dim pt As POINTAPI
    Dim rc As RECTL
    Dim lngRet As Long
    Dim s As String
    Dim hMetafile As Long
    Dim hDCMeta As Long
    Dim arrayMeta() As Byte
    Dim sngConvertX As Single
    Dim sngConvertY As Single
    Dim ImageWidth As Long
    Dim ImageHeight As Long
    Dim Xdpi As Single
    Dim Ydpi As Single
    Dim TwipsPerPixelX As Single
    Dim TwipsPerPixely As Single
    Dim sngHORZRES As Single
    Dim sngVERTRES As Single
    Dim sngHORZSIZE As Single
    Dim sngVERTSIZE As Single
    hDCref = apiGetDC(0)
    If hStdPic.Type = 0 Then
        Err.Raise vbObjectError + 523, "fStdPicToImageData.modStdPic", _
            "Sorry...This function can only read Image files." & vbCrLf & "Please Select a Valid Supported Image File"
    End If
    sngHORZRES = apiGetDeviceCaps(hDCref, HORZRES)
    sngVERTRES = apiGetDeviceCaps(hDCref, VERTRES)
    sngHORZSIZE = apiGetDeviceCaps(hDCref, HORZSIZE)
    sngVERTSIZE = apiGetDeviceCaps(hDCref, VERTSIZE)
    sngConvertX = (sngHORZSIZE * 0.1) / 2.54
    sngConvertY = (sngVERTSIZE * 0.1) / 2.54
    sngConvertX = sngHORZRES / sngConvertX
    sngConvertY = sngVERTRES / sngConvertY
    Xdpi = sngConvertX
    Ydpi = sngConvertY
    sngConvertX = hStdPic.Width * 0.001
    sngConvertY = hStdPic.Height * 0.001
    sngConvertX = sngConvertX / 2.54
    sngConvertY = sngConvertY / 2.54
    sngConvertX = sngConvertX * 1440
    sngConvertY = sngConvertY * 1440
    TwipsPerPixelX = TWIPSPERINCH / Xdpi
    TwipsPerPixely = TWIPSPERINCH / Ydpi
    ImageWidth = sngConvertX / TwipsPerPixelX
    ImageHeight = sngConvertY / TwipsPerPixely
    rc.right = hStdPic.Width
    rc.Bottom = hStdPic.Height
    s = "Stephen Lebans" & Chr(0) & Chr(0) & "www.lebans.com" & Chr(0) & Chr(0)
    hDCMeta = apiCreateEnhMetaFileRECT(hDCref, vbNullString, rc, s)
    If hDCMeta = 0 Then
        Err.Raise vbObjectError + 525, "fStdPicToImageData.modStdPic", _
        "Sorry...cannot Create Enhanced Metafile"
    End If
    lngRet = SetMapMode(hDCMeta, MM_TEXT)
    lngRet = SetWindowExtEx(hDCMeta, ImageWidth, ImageHeight, sz)
    lngRet = SetWindowOrgEx(hDCMeta, 0&, 0&, pt)
    lngRet = SetWindowExtEx(hDCMeta, ImageWidth, ImageHeight, sz)
    lngRet = SetBkMode(hDCMeta, TRANSPARENT)
    lngRet = apiSelectObject(hDCMeta, GetStockObject(NULL_BRUSH))
    lngRet = apiSelectObject(hDCMeta, GetStockObject(NULL_PEN))
    lngRet = SetStretchBltMode(hDCMeta, COLORONCOLOR)
    hStdPic.Render CLng(hDCMeta), 0&, 0&, CLng(ImageWidth), CLng(ImageHeight), 0&, hStdPic.Height, hStdPic.Width, -hStdPic.Height, vbNull
    DoEvents
    hMetafile = apiCloseEnhMetaFile(hDCMeta)
    If hMetafile = 0 Then
        fStdPicToImageData = False
        Exit Function
    End If
    lngRet = GetEnhMetaFileBits(hMetafile, 0, ByVal 0&)
    If lngRet = 0 Then
        fStdPicToImageData = False
        Exit Function
    End If
    ReDim arrayMeta((lngRet - 1) + 8)
    lngRet = GetEnhMetaFileBits(hMetafile, lngRet, arrayMeta(8))
    lngRet = apiDeleteEnhMetaFile(hMetafile)
    arrayMeta(0) = CF_ENHMETAFILE
    ctl.PictureData = arrayMeta
    If AutoSize Then
        If sngConvertX < ctl.Parent.Width Then
           ctl.Width = sngConvertX '+ 15
        Else
            ctl.Width = ctl.Parent.Width - 200
        End If
        If sngConvertY < ctl.Parent.Detail.Height Then
            ctl.Height = sngConvertY '+ 15
        Else
            ctl.Height = ctl.Parent.Detail.Height - 200
        End If
         ctl.SizeMode = acOLESizeStretch
    End If
EXIT_SHOWPIC:
    lngRet = apiReleaseDC(0&, hDCref)
    Exit Function
ERR_SHOWPIC:
    MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
    Resume EXIT_SHOWPIC
End Function


===========================================================
Modul mdlTools
===========================================================
Option Compare Database
Option Explicit

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Function Replace97(strOriginal, ByVal strSuchen As String, ByVal strErsetzen As String, Optional ByVal intVergleichsart As Integer)
    Dim strAktuellerText As String, intPosition As Integer
    If IsNull(strOriginal) Then
        Replace97 = Null
    Else
        strAktuellerText = strOriginal
        intPosition = InStr(1, strAktuellerText, strSuchen, intVergleichsart)
        Do While intPosition > 0
            strAktuellerText = Left(strAktuellerText, intPosition - 1) & strErsetzen & Mid(strAktuellerText, intPosition + Len(strSuchen))
            intPosition = InStr(intPosition + Len(strErsetzen), strAktuellerText, strSuchen, intVergleichsart)
        Loop
        Replace97 = strAktuellerText
    End If
End Function

Public Function Anwendungspfad()
    Anwendungspfad = Mid(CurrentDb.Name, 1, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
End Function

Public Function IstFormularGeoeffnet(Formularname As String)
    IstFormularGeoeffnet = SysCmd(acSysCmdGetObjectState, acForm, Formularname)
End Function

Public Function Dateidownload(ByVal strDateiadresse As String, ByVal strZieladresse As String) As Long
    DoCmd.Hourglass True
    Dim objXMLHTTP As MSXML2.XMLHTTP
    Set objXMLHTTP = New MSXML2.XMLHTTP
    Dim Buffer() As Byte
    With objXMLHTTP
        .Open "GET", strDateiadresse, False
        .send
        Do
            Sleep 1000
        Loop While .readyState <> 4
        Buffer = .responseBody
    End With
    Open strZieladresse For Binary Access Write As #1
    Put #1, , Buffer
    Close #1
    DoCmd.Hourglass False
End Function

Function URLEncode(psString)
    Dim lsString, lsChar, llLength, llPos, llVal
    For llPos = 1 To Len(psString)
        lsChar = Mid(psString, llPos, 1)
        llVal = Asc(UCase(lsChar))
        If llVal < 65 Or llVal > 90 Then
            lsChar = "%" & Hex(llVal)
        End If
        URLEncode = URLEncode & lsChar
    Next
End Function

Public Function MehrfacheLeerzeichenEntfernen(str)
    Dim pos As Integer
    pos = InStr(1, str, "  ")
    Do While pos > 0
        str = Replace97(str, "  ", " ")
        pos = InStr(1, str, "  ")
    Loop
    MehrfacheLeerzeichenEntfernen = str
End Function
