++++++++++++++++++++++++++++++++++++++++++++++++++++++++
++++++++++++++++++++++++++++++++++++++++++++++++++++++++
VBA Code of the data base 'Verleih-v601.mdb'
19.02.2019 
++++++++++++++++++++++++++++++++++++++++++++++++++++++++
++++++++++++++++++++++++++++++++++++++++++++++++++++++++

========================================================
Code of the form 'frmBuechersuche'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmBuechersuche"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Public Sub public_lstBuecher_AfterUpdate()
Call lstBuecher_AfterUpdate
End Sub

Public Sub Public_BuchdatenLoeschen()

If errorhandling Then On Error GoTo fehlerbehandlung


Me!lstAutoren.RowSourceType = "Table/Query"
Me!lstAutoren.RowSource = ""

txtVerlag = ""
txtJahr = ""
txtZustand = ""
txtNummer = ""
txtLager = ""
txtOrt = ""
txtBemerkung = ""

'Wei frben der Datenfelder

lstAutoren.BackColor = RGB(255, 255, 255)
txtVerlag.BackColor = RGB(255, 255, 255)
txtJahr.BackColor = RGB(255, 255, 255)
txtZustand.BackColor = RGB(255, 255, 255)
txtNummer.BackColor = RGB(255, 255, 255)
txtLager.BackColor = RGB(255, 255, 255)
txtOrt.BackColor = RGB(255, 255, 255)
txtBemerkung.BackColor = RGB(255, 255, 255)

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstBuecher_AfterUpdate()
'--------------------------------------------------------------
'Anzeige der Daten des ausgewhlten Buches

Dim strSQL As String

If errorhandling Then On Error GoTo fehlerbehandlung

'Zeige in der Autorenliste die Autoren zu dem ausgewhlten Buch an

strSQL = "SELECT tblAutor.autor_id, tblAutor.autor_name, tblAutor.autor_vorname " & _
         "FROM tblAutor INNER JOIN tblAutor_Buch " & _
         "ON tblAutor.autor_id = tblAutor_Buch.autor_id_f " & _
         "WHERE tblAutor_Buch.buch_id_f = " & Str(lstBuecher)

'Debug.Print strSQL

Me!lstAutoren.RowSourceType = "Table/Query"
Me!lstAutoren.RowSource = strSQL

'Zeige die brigen Daten zu dem ausgewhlten Buch an

txtVerlag = DLookup("ver_name", "qryBuch", "buch_id=" & Str(lstBuecher))
txtJahr = DLookup("buch_jahr", "qryBuch", "buch_id=" & Str(lstBuecher))
txtZustand = DLookup("zust_name", "qryBuch", "buch_id=" & Str(lstBuecher))
txtNummer = DLookup("buch_nummer", "qryBuch", "buch_id=" & Str(lstBuecher))
txtLager = DLookup("lager_bezeichnung", "qryBuch", "buch_id=" & Str(lstBuecher))
txtOrt = DLookup("ort_bezeichnung", "qryBuch", "buch_id=" & Str(lstBuecher))
txtBemerkung = DLookup("buch_bemerkung", "qryBuch", "buch_id=" & Str(lstBuecher))

'Frben der Datenfelder
lstAutoren.BackColor = RGB(164, 213, 226)
txtVerlag.BackColor = RGB(164, 213, 226)
txtJahr.BackColor = RGB(164, 213, 226)
txtZustand.BackColor = RGB(164, 213, 226)
txtNummer.BackColor = RGB(164, 213, 226)
txtLager.BackColor = RGB(164, 213, 226)
txtOrt.BackColor = RGB(164, 213, 226)
txtBemerkung.BackColor = RGB(164, 213, 226)

' Ist dieses Buch bereits ausgeliehen?

If DCount("aus_id", "tblAusleihe", "buch_id_f=" & Str(lstBuecher) & _
                                  " AND aus_bis IS NULL") > 0 Then
   txtAusgeliehen.Caption = "Dieses Buch ist ausgeliehen seit dem " & _
         DLookup("aus_von", "tblAusleihe", "buch_id_f=" & Str(lstBuecher) & _
                                           " AND aus_bis IS NULL")
   txtAusgeliehen.Visible = True
Else
   txtAusgeliehen.Visible = False
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("buechersuche")
End Sub

Private Sub cmdObersachgebiet_Click()
'--------------------------------------------------------------
' Mache das Obersachgebiet des aktuellen Sachgebietes zum aktuellen Sachgebiet
' (Oder, mit anderen Worten: Gehe im Sachgebietsbaum einen Schritt zurck)

Dim strSQL As String

If errorhandling Then On Error GoTo fehlerbehandlung

'Zeige das Obersachgebiet an

txtAktuellesSachgebiet = Me!OBERSACHGEBIET

'Mache das Obersachgebiet zum aktuellen Sachgebiet

Me.Filter = "tblSachgebiet.sachgebiet='" & Me!OBERSACHGEBIET & "'"
Me.FilterOn = True

'Zeige in der Bcherliste die Bcher zum aktuellen Sachgebiet an

strSQL = "SELECT tblBuch.buch_id, tblBuch.BUCH_TITEL " & _
          "FROM tblBuch_Sach INNER JOIN tblBuch " & _
          "ON tblBuch.buch_id = tblBuch_Sach.buch_id_f " & _
          "WHERE tblBuch_Sach.sachgebiet ='" & txtAktuellesSachgebiet & "'"

Me!lstBuecher.RowSourceType = "Table/Query"
Me!lstBuecher.RowSource = strSQL

' Anzeige der ersten Zeile der Liste

If Nz(lstBuecher.ListCount) > 0 Then   ' erste Zeile auswhlen
   Me!lstBuecher = Me!lstBuecher.ItemData(0)
   Call lstBuecher_AfterUpdate
Else
   Call Public_BuchdatenLoeschen
   txtAusgeliehen.Visible = False
End If

lstSachgebiete = Null

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdOberstesSachgebiet_Click()
'--------------------------------------------------------------
' Zurck zum obersten Sachgebiet

Dim rs As DAO.Recordset
Dim strOberstesSachgebiet As String
Dim strSQL As String

If errorhandling Then On Error GoTo fehlerbehandlung

'Finde das oberste Sachgebiet

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = obersachgebiet"
strOberstesSachgebiet = rs!SACHGEBIET
rs.Close
Set rs = Nothing

'Zeige das oberste Sachgebiet an

txtAktuellesSachgebiet = strOberstesSachgebiet

'Mache das oberste Sachgebiet zum aktuellen Sachgebiet

Me.Filter = "tblSachgebiet.sachgebiet='" & strOberstesSachgebiet & "'"
Me.FilterOn = True

'Zeige in der Bcherliste die Bcher zum aktuellen Sachgebiet an

strSQL = "SELECT tblBuch.buch_id, tblBuch.BUCH_TITEL " & _
          "FROM tblBuch_Sach INNER JOIN tblBuch " & _
          "ON tblBuch.buch_id = tblBuch_Sach.buch_id_f " & _
          "WHERE tblBuch_Sach.sachgebiet ='" & txtAktuellesSachgebiet & "'"

Me!lstBuecher.RowSourceType = "Table/Query"
Me!lstBuecher.RowSource = strSQL

' Anzeige der ersten Zeile der Liste

If Nz(lstBuecher.ListCount) > 0 Then   ' erste Zeile auswhlen
   Me!lstBuecher = Me!lstBuecher.ItemData(0)
   Call lstBuecher_AfterUpdate
Else
   Call Public_BuchdatenLoeschen
   txtAusgeliehen.Visible = False
End If

lstSachgebiete = Null

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
'Zeige nach dem ffnen das oberste Sachgebiet an!

Dim rs As DAO.Recordset

Me.Cycle = 1

If errorhandling Then On Error GoTo fehlerbehandlung

'Finde das oberste Sachgebiet

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = obersachgebiet"

If rs.NoMatch Then
   MsgBox "Es gibt kein Sachgebiet, bei dem sachgebiet=obersachgebiet ist" & vbCrLf & _
          "(oberstes Sachgebiet). Bitte legen Sie ein solches Sachgebiet an," & vbCrLf & _
          "sonst wird dieses Formular nicht funktionieren!"
   rs.Close
   Set rs = Nothing
   Exit Sub
End If

txtAktuellesSachgebiet = rs!SACHGEBIET
rs.Close
Set rs = Nothing

'Die Filterung sorgt dafr, dass im Unterformular die zum aktuellen
'Sachgebiet gehrenden Untersachgebiete angezeigt werden.

Me.Filter = "tblSachgebiet.sachgebiet='" & txtAktuellesSachgebiet & "'"
Me.FilterOn = True

'Leeren der Autorenliste

Me!lstAutoren.RowSourceType = "Table/Query"
Me!lstAutoren.RowSource = ""
Me!lstAutoren.Requery

'Leeren der Bcherliste

Me!lstBuecher.RowSourceType = "Table/Query"
Me!lstBuecher.RowSource = ""
Me!lstBuecher.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstBuecher_DblClick(Cancel As Integer)
'--------------------------------------------------------------
' Von der Suche direkt zur Ausleihe

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmAusleihe", , , , , , Me!lstBuecher

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstSachgebiete_AfterUpdate()
'--------------------------------------------------------------
'Die Daten des in der Liste angeclickten Datensatzes anzeigen

Dim strSQL As String

If errorhandling Then On Error GoTo fehlerbehandlung

'Mache das in der Liste angeclickte Sachgebiet zum aktuellen Sachgebiet
txtAktuellesSachgebiet = lstSachgebiete

'Die Filterung sorgt dafr, dass im Unterformular die zum aktuellen
'Sachgebiet gehrenden Untersachgebiete angezeigt werden.
' ACHTUNG: Die Anzeige ALLER Sachgebiete in der Liste bleibt davon unbeeinflusst!
'          Es wird nur die Datenquelle DES FORMULARS gefiltert!

Me.Filter = "tblSachgebiet.sachgebiet='" & txtAktuellesSachgebiet & "'"
Me.FilterOn = True

'Zeige in der Bcherliste die Bcher zum aktuellen Sachgebiet an

strSQL = "SELECT tblBuch.buch_id, tblBuch.buch_titel " & _
          "FROM tblBuch_Sach INNER JOIN tblBuch " & _
          "ON tblBuch.buch_id = tblBuch_Sach.buch_id_f " & _
          "WHERE tblBuch_Sach.sachgebiet ='" & txtAktuellesSachgebiet & "'" & _
          " ORDER BY tblBuch.buch_titel"

lstBuecher.RowSourceType = "Table/Query"
lstBuecher.RowSource = strSQL

' Anzeige der ersten Zeile der Liste

If Nz(lstBuecher.ListCount) > 0 Then   ' erste Zeile auswhlen
   Me!lstBuecher = Me!lstBuecher.ItemData(0)
   Call lstBuecher_AfterUpdate
Else
   Call Public_BuchdatenLoeschen
End If

' funktioniert NICHT:
'lstBuecher.SetFocus
'lstBuecher.Selected(0) = True
'Call lstBuecher_AfterUpdate

'funktioniert NICHT:
'Me!frmBuechersuche_ufoUntersachgebiete.Filter = _
'      "tblSachgebiet.sachgebiet='" & txtAktuellesSachgebiet & "'"
'Me!frmBuechersuche_ufoUntersachgebiete.FilterOn = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmOrte'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmOrte"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1

' Wenn das Formular mittels Doppelclick von einem anderen Formular aus geffnet wird,
' soll der dort angeclickte Datensatz angezeigt werden.
' Ansonsten soll der erste Datensatz angezeigt werden.

Me!lstOrte.SetFocus

If IsNull(OpenArgs) Then

   If Nz(lstOrte.ListCount) > 0 Then   ' erste Zeile auswhlen
      Me!lstOrte = Me!lstOrte.ItemData(0)
      Call lstOrte_AfterUpdate
   End If

Else
   Me!lstOrte = OpenArgs
   Call lstOrte_AfterUpdate
End If

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub ORT_BEMERKUNG_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub ORT_BEZEICHNUNG_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstOrte_AfterUpdate()
'--------------------------------------------------------------
'In der Liste ausgewhlten Datensatz anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstOrte) Then Me.Recordset.FindFirst "ort_id=" & Me!lstOrte

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("orte")
End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
' Einen Ort lschen
' (alternative Variante!)

Dim strMsgtext As String

If errorhandling Then On Error GoTo fehlerbehandlung

'Wurde ein zu lschender Datensatz ausgewhlt?

If IsNull(lstOrte) Then
   MsgBox "Bitte whlen Sie den zu lschenden Ort aus der Liste!"
   lstOrte.SetFocus
   Exit Sub
End If

strMsgtext = "Wollen Sie den Ort " & Me!txtBezeichnung & " wirklich lschen?"

If MsgBox(strMsgtext, vbYesNo + vbDefaultButton2) = vbYes Then

   'Gibt es noch Datenstze in anderen Tabellen, die mit dem zu lschenden
   'Datensatz in Beziehung stehen ?

   If DCount("lager_id", "tblLager", "ort_id_f=" & Me!ort_id) > 0 Then
      MsgBox "Dieser Ort kann nicht gelscht werden!" & vbCrLf & _
             "Es gibt dort noch mindestens ein Lager."
   Else
      CurrentDb.Execute "DELETE FROM tblOrt WHERE ort_id=" & Str(Me!ort_id)
      lstOrte.Requery
      Requery

      Me!lstOrte.SetFocus
      If Nz(lstOrte.ListCount) > 0 Then   ' erste Zeile auswhlen
         Me!lstOrte = Me!lstOrte.ItemData(0)
         Call lstOrte_AfterUpdate
      End If
   
   End If

End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------
Dim lngOrtId As Long

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtBezeichnung) = "" Then
   MsgBox "Bitte geben Sie eine Bezeichnung ein!"
   txtBezeichnung.SetFocus
   Exit Sub
End If

' Gibt es diesen Ort schon?

If (txtBezeichnung <> txtBezeichnung.OldValue Or _
    IsNull(txtBezeichnung.OldValue)) And _
   DCount("ort_id", "tblOrt", "ort_bezeichnung='" & txtBezeichnung & "'") > 0 Then
   MsgBox ("Diesen Ort gibt es schon!")
   Me.Undo   ' Abbrechen der begonnenen Transaktion (Datensatzmarkierer beobachten!!)
   txtBezeichnung.SetFocus
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord
lngOrtId = Me!ort_id

lstOrte.Enabled = True
lstOrte.Requery
lstOrte.SetFocus

' Anzeige des gespeicherten Ortes

lstOrte = lngOrtId
Call lstOrte_AfterUpdate

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub
Private Sub cmdNeu_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

lstOrte = Null
DoCmd.GoToRecord , , acNewRec
txtBezeichnung.SetFocus

cmdLoeschen.Enabled = False
cmdNeu.Enabled = False
lstOrte.Enabled = False

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtBezeichnung_BeforeUpdate(Cancel As Integer)
' Ist das Eingabefeld leer?
' Cancel = True bewirkt, dass das Update NICHT ausgefhrt wird,
' was in diesem Fall bedeutet, dass der Inhalt des Eingabefeldes
' nicht gelscht wird!
' Das Drcken der Esc-Taste bewirkt, dass ein gelschter Wert
' wieder hergestellt wird.
' Summa summarun wird alo verhindert, dass der Datensatz mit
' einem leeren Eingabefeld gespeichert wird!

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(Me!txtBezeichnung) = "" Then
   MsgBox "Bitte geben Sie eine Bezeichnung ein oder drcken Sie die Esc-Taste!"
   Cancel = True
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmSpaltenFuellen'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmSpaltenFuellen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdStart_Click()

If errorhandling Then On Error GoTo fehlerbehandlung

Dim lngZeile As Long
Dim lngAnzahlZeilen As Long
Dim strSQL As String
Dim rs As DAO.Recordset
Dim tdef As TableDef
Dim blnGefunden As Boolean
Dim tabspalte As Field

lblFertig.Visible = False

If Nz(txtInTabelle) = "" Then
   MsgBox "Bitte geben Sie den Namen der Zieltabelle ein!"
   txtInTabelle.SetFocus
   Exit Sub
End If

If Nz(txtInSpalte) = "" Then
   MsgBox "Bitte geben Sie den Namen der Zielspalte ein!"
   txtInSpalte.SetFocus
   Exit Sub
End If

' Existiert die Zieltabelle?

blnGefunden = False
For Each tdef In CurrentDb.TableDefs
   If tdef.Name = txtInTabelle Then
      blnGefunden = True
      Exit For
   End If
Next tdef

If Not blnGefunden Then
   MsgBox "Es gibt keine Tabelle mit dem Namen " & txtInTabelle & "!"
   DoCmd.Hourglass False
   txtInTabelle.SetFocus
   Exit Sub
End If

' Existiert die Zielspalte?

blnGefunden = False
For Each tabspalte In tdef.Fields
   If tabspalte.Name = txtInSpalte Then blnGefunden = True
Next tabspalte

If Not blnGefunden Then
   MsgBox "Es gibt in der Tabelle " & txtInTabelle & _
          " keine Spalte mit dem Namen " & txtInSpalte & "!"
   DoCmd.Hourglass False
   txtInSpalte.SetFocus
   Exit Sub
End If

' Das knnte lange dauern - darum Anzeige der Sanduhr

DoCmd.Hourglass True

' Wieviele Zeilen hat die Tabelle tblFuelltext?

lngAnzahlZeilen = Nz(DCount("fuell_id", "tblFuelltext"))

If lngAnzahlZeilen = 0 Then
   MsgBox "Die Tabelle tblFuelltext ist leer!"
   Exit Sub
End If

' Nummer der Zeile der Tabelle tblFuelltext, in der begonnen werden soll
' (standardmig die erste - man kann aber auch irgendwo anders beginnen)

lngZeile = DMin("fuell_id", "tblFuelltext")
'lngZeile = 99

' Trick17: Die Spalte, in die die Daten HINEIN sollen, bekommt
' den Aliasnamen "fuellspalte". Darum braucht man sich nachher beim Fllen
' nicht mehr um den konkreten Namen der Spalte zu kmmern und kann
' einfach schreiben "rs!fuellspalte"

strSQL = "SELECT " & txtInSpalte & " AS fuellspalte FROM " & txtInTabelle

' Jeweils EINEN Flltext in jede zu fllende Zelle

Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF
   rs.Edit
   rs!fuellspalte = DLookup("fuell_text", "tblFuelltext", "fuell_id=" & Str(lngZeile))
   rs.Update
   lngZeile = lngZeile + 1   ' nchste Zeile in tblFuelltext
   If lngZeile > lngAnzahlZeilen Then lngZeile = 1   ' ggf. von vorne beginnen
   rs.MoveNext
Loop

' Jeweils ZWEI Flltexte in jede zu fllende Zelle

'Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
'Do Until rs.EOF
'   rs.Edit
'   rs!fuellspalte = DLookup("fuell_text", "tblFuelltext", "fuell_id=" & Str(lngZeile))
'   lngZeile = lngZeile + 1   ' nchste Zeile in tblFuelltext
'   If lngZeile > lngAnzahlZeilen Then lngZeile = 1   ' ggf. von vorne beginnen
'   rs!fuellspalte = rs!fuellspalte & " " & _
'                    DLookup("fuell_text", "tblFuelltext", "fuell_id=" & Str(lngZeile))
'   rs.Update
'   lngZeile = lngZeile + 1   ' nchste Zeile in tblFuelltext
'   If lngZeile > lngAnzahlZeilen Then lngZeile = 1   ' ggf. von vorne beginnen
'   rs.MoveNext
'Loop


rs.Close
Set rs = Nothing

DoCmd.Hourglass False
lblFertig.Visible = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
txtInTabelle.SetFocus
lblFertig.Visible = False
End Sub

Private Sub txtInSpalte_Change()
lblFertig.Visible = False
End Sub

Private Sub txtInTabelle_Change()
lblFertig.Visible = False
End Sub

Private Sub txtVonSpalte_Change()
lblFertig.Visible = False
End Sub

Private Sub txtVonTabelle_Change()
lblFertig.Visible = False
End Sub

========================================================
Code of the form 'frmLager'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmLager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cboLagertyp_AfterUpdate()
'--------------------------------------------------------------
' Durch die nderung des Wertes in einem Kombinationsfeld wird eine
' Transaktion (nderung von Daten in der Datenbank) begonnen
' (erkennbar am Schreibstift im Datensatzmarkierer!).
' Da eine nicht ordnungsgem beendete Transaktion zu Fehlern fhren kann,
' wird die gerade begonnene Transaktion auch sofort wieder durch einen
' "Speichern"-Befehl beendet.

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.RunCommand (acCmdSaveRecord)

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboLagertyp_Dirty(Cancel As Integer)
'--------------------------------------------------------------
' Sicherheitsmanahme gegen versehentliches ndern von Daten durch
' Clicken in ein Kombinationsfeld
' Beim erstmaligen Eintrag von Daten (OldValue=Null) wird nicht nachgefragt.

If errorhandling Then On Error GoTo fehlerbehandlung

If IsNull(cboLagertyp.OldValue) Then Exit Sub
If MsgBox("Wollen Sie den Lagertyp wirklich ndern?", vbYesNo + vbDefaultButton2) = vbNo Then
   Cancel = True       ' Abbruch der Bearbeitung
   SendKeys ("{ESC}")  ' Schlieen der Combobox
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboLagertyp_GotFocus()
'--------------------------------------------------------------
' Wenn der Inhalt der Combobox in einem anderen Formular gendert wurde,
' soll die nderung hier sofort sichtbar werden

If errorhandling Then On Error GoTo fehlerbehandlung

cboLagertyp.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboOrt_AfterUpdate()
'--------------------------------------------------------------
' Durch die nderung des Wertes in einem Kombinationsfeld wird eine
' Transaktion (nderung von Daten in der Datenbank) begonnen
' (erkennbar am Schreibstift im Datensatzmarkierer!).
' Da eine nicht ordnungsgem beendete Transaktion zu Fehlern fhren kann,
' wird die gerade begonnene Transaktion auch sofort wieder durch einen
' "Speichern"-Befehl beendet.

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.RunCommand (acCmdSaveRecord)

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboOrt_Dirty(Cancel As Integer)
'--------------------------------------------------------------
' Sicherheitsmanahme gegen versehentliches ndern von Daten durch
' Clicken in ein Kombinationsfeld
' Beim erstmaligen Eintrag von Daten (OldValue=Null) wird nicht nachgefragt.

If errorhandling Then On Error GoTo fehlerbehandlung

If IsNull(cboOrt.OldValue) Then Exit Sub
If MsgBox("Wollen Sie den Ort wirklich ndern?", vbYesNo + vbDefaultButton2) = vbNo Then
   Cancel = True       ' Abbruch der Bearbeitung
   SendKeys ("{ESC}")  ' Schlieen der Combobox
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboOrt_GotFocus()
'--------------------------------------------------------------
' Wenn der Inhalt der Combobox in einem anderen Formular gendert wurde,
' soll die nderung hier sofort sichtbar werden

If errorhandling Then On Error GoTo fehlerbehandlung

cboOrt.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1

' Wenn das Formular mittels Doppelclick von einem anderen Formular aus geffnet wird,
' soll der dort angeclickte Datensatz angezeigt werden.
' Ansonsten soll der erste Datensatz angezeigt werden.

Me!lstLager.SetFocus

If IsNull(OpenArgs) Then

   If Nz(lstLager.ListCount) > 0 Then   ' erste Zeile auswhlen
      Me!lstLager = Me!lstLager.ItemData(0)
      Call lstLager_AfterUpdate
   End If

Else
   Me!lstLager = OpenArgs
   Call lstLager_AfterUpdate
End If

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub LAGER_BEZEICHNUNG_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstLager_AfterUpdate()
'--------------------------------------------------------------
'Die Daten des in der Liste angeclickten Datensatzes anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstLager) Then Me.Recordset.FindFirst "lager_id=" & Me!lstLager

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("lager")
End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
'Ein Lager lschen
' (alternative Technik in frmOrte!)

Dim lngAntwort As Long
Dim strMsgtext As String
Dim rs As DAO.Recordset

If errorhandling Then On Error GoTo fehlerbehandlung

'Wurde ein zu lschender Datensatz ausgewhlt?
If IsNull(lstLager) Then
   MsgBox "Bitte whlen Sie das zu lschende Lager aus der Liste!"
   lstLager.SetFocus
   Exit Sub
End If

strMsgtext = "Wollen Sie das Lager " & Me!LAGER_BEZEICHNUNG & " wirklich lschen?"

'Gibt es noch Datenstze in anderen Tabellen, die mit dem zu lschenden
'Datensatz in Beziehung stehen ?

Set rs = CurrentDb.OpenRecordset("tblBuch", dbOpenDynaset)
rs.FindFirst "lager_id_f=" & Str(Me!lager_id)

If rs.NoMatch Then
   lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
   rs.Close
   Set rs = Nothing
   If lngAntwort = vbNo Then Exit Sub
   CurrentDb.Execute "DELETE FROM tblLager WHERE lager_id=" & Str(Me!lager_id)
   lstLager.Requery
   Requery

   Me!lstLager.SetFocus
   If Nz(lstLager.ListCount) > 0 Then   ' erste Zeile auswhlen
      Me!lstLager = Me!lstLager.ItemData(0)
      Call lstLager_AfterUpdate
   End If

Else
   MsgBox "Dieses Lager kann nicht gelscht werden!" & vbCrLf & _
          "Es enthlt noch Bcher."
   rs.Close
   Set rs = Nothing
   Exit Sub
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------
Dim lngLagerId As Long

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtBezeichnung) = "" Then
   MsgBox "Bitte geben Sie eine Bezeichnung ein!"
   txtBezeichnung.SetFocus
   Exit Sub
End If

If IsNull(cboLagertyp) Then
   MsgBox "Bitte whlen Sie einen Lagertyp aus!"
   Exit Sub
End If

If IsNull(cboOrt) Then
   MsgBox "Bitte whlen Sie einen Ort aus!"
   Exit Sub
End If

' Gibt es diese Bezeichnung schon an dem ausgewhlten Ort?

If (txtBezeichnung <> txtBezeichnung.OldValue Or cboOrt <> cboOrt.OldValue) And _
    DCount("lager_id", "tblLager", "lager_bezeichnung='" & txtBezeichnung & "' AND " & _
                                   "ort_id_f=" & Str(cboOrt)) > 0 Then
   MsgBox ("Diese Lagerbezeichnung gibt es schon an dem Ort." & vbCrLf & _
           "Bitte whlen Sie eine andere Bezeichnung!")
   Me.Undo    ' Abbrechen der begonnenen Transaktion (Datensatzmarkierer beobachten!!)
   txtBezeichnung.SetFocus
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord
lngLagerId = Me!lager_id

lstLager.Enabled = True
lstLager.Requery
lstLager.SetFocus
lstLager = lngLagerId
Call lstLager_AfterUpdate

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub
Private Sub cmdNeu_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

lstLager = Null
DoCmd.GoToRecord , , acNewRec
txtBezeichnung.SetFocus

cmdLoeschen.Enabled = False
cmdNeu.Enabled = False
lstLager.Enabled = False

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtBezeichnung_BeforeUpdate(Cancel As Integer)
' Ist das Eingabefeld leer?
' Cancel = True bewirkt, dass das Update NICHT ausgefhrt wird,
' was in diesem Fall bedeutet, dass der Inhalt des Eingabefeldes
' nicht gelscht wird!
' Das Drcken der Esc-Taste bewirkt, dass ein gelschter Wert
' wieder hergestellt wird.
' Summa summarun wird alo verhindert, dass der Datensatz mit
' einem leeren Eingabefeld gespeichert wird!

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(Me!txtBezeichnung) = "" Then
   MsgBox "Bitte geben Sie eine Bezeichnung ein oder drcken Sie die Esc-Taste!"
   Cancel = True
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmStart'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmStart"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdAusleihe_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmAusleihe"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdBeenden_Click()
'--------------------------------------------------------------
If errorhandling Then On Error GoTo fehlerbehandlung

If MsgBox("Wollen Sie die Arbeit wirklich beenden und MS-Access schlieen?", _
          vbYesNo + vbDefaultButton2) = vbYes Then DoCmd.Quit
Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdBuecherSuchen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmBuechersuche"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
'Zeige die Versionsnummer an

Dim rs As DAO.Recordset

If errorhandling Then On Error GoTo fehlerbehandlung

' Holen der Versionsnummer aus der Tabelle DBinfo

Set rs = CurrentDb.OpenRecordset("tblDBINFO", dbOpenDynaset)
rs.FindFirst "dbi_name='version'"

If rs.NoMatch Then
  Me!lblVersion.Caption = ""
Else
  Me!lblVersion.Caption = rs!dbi_wert
End If

rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdAutoren_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmAutoren"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdVerlage_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmVerlage"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdRueckgabe_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmRueckgabe"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdOrte_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmOrte"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdLager_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmLager"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSachgebiete_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmSachgebiete"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdBuecher_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmBuecher"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub


========================================================
Code of the form 'frmAutoren'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmAutoren"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdAlleAutoren_Click()
DoCmd.OpenReport "rptAutoren", acViewPreview
End Sub

Private Sub cmdEinenAutor_Click()
DoCmd.OpenReport "rptAutoren", acViewPreview, , "autor_id=" & Me!autor_id
End Sub

Private Sub Form_Current()
'--------------------------------------------------------------
' Markiert in der Liste den im Formular per PgUp / PgDown ausgewhlten Datensatz
'Me!lstAutoren = Me!autor_id
End Sub

Private Sub txtBemerkung_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtName_BeforeUpdate(Cancel As Integer)
' Ist das Eingabefeld leer?
' Cancel = True bewirkt, dass das Update NICHT ausgefhrt wird,
' was in diesem Fall bedeutet, dass der Inhalt des Eingabefeldes
' nicht gelscht wird!
' Das Drcken der Esc-Taste bewirkt, dass ein gelschter Wert
' wieder hergestellt wird.
' Summa summarun wird alo verhindert, dass der Datensatz mit
' einem leeren Eingabefeld gespeichert wird!

If Nz(Me!txtName) = "" Then
   MsgBox "Bitte geben Sie einen Namen ein oder drcken Sie die Esc-Taste!"
   Cancel = True
End If

End Sub

Private Sub txtName_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtVorname_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstAutoren_AfterUpdate()
'--------------------------------------------------------------
'Die Daten des in der Liste angeclickten Datensatzes anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstAutoren) Then Me.Recordset.FindFirst "autor_id=" & Str(Me!lstAutoren)

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("autoren")
End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
' Einen Autor lschen
' (alternative Technik in frmOrte!)

Dim lngAntwort As Long
Dim strMsgtext As String
Dim rs As DAO.Recordset

If errorhandling Then On Error GoTo fehlerbehandlung

'Wurde ein zu lschender Datensatz ausgewhlt?

If IsNull(lstAutoren) Then
   MsgBox "Bitte whlen Sie den zu lschenden Autor aus der Liste!"
   lstAutoren.SetFocus
   Exit Sub
End If

strMsgtext = "Wollen Sie " & Nz(AUTOR_VORNAME) & " " & Me!AUTOR_NAME & " wirklich lschen?"

'Gibt es noch Datenstze in anderen Tabellen, die mit dem zu lschenden
'Datensatz in Beziehung stehen ?

Set rs = CurrentDb.OpenRecordset("tblAutor_Buch", dbOpenDynaset)
rs.FindFirst "autor_id_f=" & Str(Me!autor_id)

If rs.NoMatch Then
   lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
   If lngAntwort = vbYes Then
      CurrentDb.Execute "DELETE FROM tblAutor WHERE autor_id=" & Str(Me!autor_id)
      lstAutoren.Requery
      Requery
      
      Me!lstAutoren.SetFocus
      If Nz(lstAutoren.ListCount) > 0 Then   ' erste Zeile auswhlen
         Me!lstAutoren = Me!lstAutoren.ItemData(0)
         Call lstAutoren_AfterUpdate
      End If
      
   End If
Else
   MsgBox "Dieser Autor kann nicht gelscht werden!" & vbCrLf & _
          "Es gibt noch Bcher von ihm."
End If

rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------
Dim lngAutorId As Long

'Hat der Nutzer alle erforderlichen Daten eingegeben?

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtName) = "" Then
   MsgBox "Bitte geben Sie einen Nachnamen ein!"
   txtName.SetFocus
   Exit Sub
End If

' Gibt es diesen Autoren schon?

If (txtName <> txtName.OldValue Or txtVorname <> txtVorname.OldValue) And _
    DCount("autor_id", "tblAutor", "autor_name='" & txtName & "' AND " & _
                                   "autor_vorname='" & txtVorname & "'") > 0 Then
   MsgBox ("Diesen Autor gibt es schon!")
   Me.Undo   ' Abbrechen der begonnenen Transaktion (Datensatzmarkierer beobachten!!)
   txtName.SetFocus
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord
lngAutorId = Me!autor_id

lstAutoren.Enabled = True
lstAutoren.Requery
lstAutoren.SetFocus

' Anzeige des gerade gespeicherten Autors

lstAutoren = lngAutorId
Call lstAutoren_AfterUpdate

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdNeu_Click()
'--------------------------------------------------------------
'Neuen Autor eingeben

If errorhandling Then On Error GoTo fehlerbehandlung


DoCmd.GoToRecord , , acNewRec
txtName.SetFocus

lstAutoren = Null
cmdLoeschen.Enabled = False
cmdNeu.Enabled = False
lstAutoren.Enabled = False

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1
' Wenn das Formular mittels Doppelclick von einem anderen Formular aus geffnet wird,
' soll der dort angeclickte Datensatz angezeigt werden.
' Ansonsten soll der erste Datensatz angezeigt werden.

Me!lstAutoren.SetFocus

If IsNull(OpenArgs) Then

   If Nz(lstAutoren.ListCount) > 0 Then   ' erste Zeile auswhlen
      Me!lstAutoren = Me!lstAutoren.ItemData(0)
      Call lstAutoren_AfterUpdate
   End If

Else
   Me!lstAutoren = OpenArgs
   Call lstAutoren_AfterUpdate
End If

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub


========================================================
Code of the form 'frmExecSQL'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmExecSQL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit


Private Sub cmdLoeschen_Click()
txtSqlbefehl.Value = ""
txtSqlbefehl.SetFocus
End Sub

Private Sub cmdAusfuehren_Click()
On Error GoTo fehler

If txtSqlbefehl <> "" Then

   DoCmd.RunSQL txtSqlbefehl.Value
   MsgBox "Befehl erfolgreich ausgefhrt." & vbCrLf & _
          "Bitte kontrollieren Sie die Wirkung in der Datenbank!", _
          vbOKOnly + vbInformation

End If

Exit Sub
fehler:
    MsgBox "Bei der Ausfhrung des SQL-Befehls" & vbCrLf & vbCrLf & _
           txtSqlbefehl & vbCrLf & vbCrLf & _
           "trat der Fehler Nr. " & Err.Number & " auf: " & vbCrLf & vbCrLf & _
           Err.Description, vbOKOnly + vbExclamation
    txtSqlbefehl.SetFocus
    
End Sub


========================================================
Code of the form 'Vorlage-Formular'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_Vorlage-Formular"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdStart_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
'--------------------------------------------------------------
'Hilfe-Datei anzeigen

Dim strDateiname As String
Dim objFso As Object

If errorhandling Then On Error GoTo fehlerbehandlung

strDateiname = Application.CurrentProject.Path & "\hilfe-formularname"

' In Access 2003 (= Version 11.0) knnen Textboxen keine .rtf-Daten darstellen.
' Darum dort nur .txt-Dateien als Hilfedateien!

If Application.version < "12.0" Then     ' Access 2000/2003
   strDateiname = strDateiname & ".txt"
Else                                     ' Access 2007
   strDateiname = strDateiname & ".rtf"
End If

Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FileExists(strDateiname) Then
   DoCmd.OpenForm "Hilfe", , , , , , strDateiname
Else
   MsgBox "Fr dieses Formular existiert leider keine Hilfe-Information."
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmAusleihe'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmAusleihe"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("ausleihe")
End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------

Dim lngBuchId As Long
Dim lngPerId As Long
Dim lngGibtsSchon As Long
Dim strSQL As String

If errorhandling Then On Error GoTo fehlerbehandlung

'Hat der Nutzer alle erforderlichen Daten eingegeben?

If Nz(txtBuchtitel) = "" Then
   MsgBox "Bitte whlen Sie ein Buch aus!"
   Exit Sub
End If

If Nz(txtNachname) = "" Then
   MsgBox "Bitte whlen Sie eine Person aus!"
   Exit Sub
End If

If Nz(txtAusVon) = "" Then
   MsgBox "Bitte geben Sie ein Ausleihdatum ein!"
   txtAusVon.SetFocus
   Exit Sub
End If

lngBuchId = Me!frmAusleihe_ufoBuecher!buch_id   ' im UFO ausgewhltes Buch
lngPerId = Me!frmAusleihe_ufoPersonen!per_id    ' im UFO ausgewhlte Person

'Ist diese Ausleihe schon eingetragen worden?
'Wenn ja, braucht sie nicht noch einmal eingetragen zu werden.
'(Es muss sich dabei allerdings um einen Eintrag ohne Datum in der
'Spalte AUS_BIS handeln, denn das Buch knnte ja frher schon einmal
'ausgeliehen und wieder zurckgegeben worden sein. Dann wrde es sich
'jetzt um eine erneute Ausleihe desselben Buches handeln.)

lngGibtsSchon = DCount("buch_id_f", "tblAusleihe", "buch_id_f=" & Str(lngBuchId) & _
                   " AND per_id_f=" & Str(lngPerId) & _
                   " AND aus_bis IS NULL")
If lngGibtsSchon > 0 Then
   MsgBox "Diese Ausleihe wurde bereits eingetragen!"
   Exit Sub
End If

strSQL = "INSERT INTO tblAusleihe (buch_id_f, per_id_f, aus_von, aus_bemerkung) VALUES (" & _
         Str(lngBuchId) & "," & Str(lngPerId) & "," & _
         "'" & Str(txtAusVon) & "','" & txtBemerkung & "')"
'MsgBox strSQL
CurrentDb.Execute (strSQL)
lblGespeichert.Visible = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1

txtBemerkung = ""
txtAusVon = Date
lblGespeichert.Visible = False

' Wenn das Formular mittels Doppelclick von einem anderen Formular aus geffnet wird,
' soll das dort angeclickte Buch angezeigt werden.
' Ansonsten soll das erste Buch angezeigt werden.

If IsNull(OpenArgs) Then   ' Anzeige des ersten Buches in der Liste

   If Nz(Me!frmAusleihe_ufoBuecher.Form.lstBuecher.ListCount) > 0 Then   ' erste Zeile auswhlen
      Me!frmAusleihe_ufoBuecher.Form.lstBuecher = Me!frmAusleihe_ufoBuecher.Form.lstBuecher.ItemData(0)
      Call frmAusleihe_ufoBuecher.Form.public_lstBuecher_AfterUpdate
   End If

Else    ' Anzeige des in einem anderen Formular angeclickten Buches

   Me!frmAusleihe_ufoBuecher.Form.lstBuecher = OpenArgs
   Call frmAusleihe_ufoBuecher.Form.public_lstBuecher_AfterUpdate
   
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmAusleihe_ufoBuecher'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmAusleihe_ufoBuecher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub Form_Current()
Me!lstBuecher = Me!buch_id
End Sub

Public Sub public_lstBuecher_AfterUpdate()
Call lstBuecher_AfterUpdate
End Sub

Private Sub lstBuecher_AfterUpdate()
'--------------------------------------------------------------
'Die Daten des in der Liste angeclickten Datensatzes anzeigen
Dim lngAusId As Long
Dim lngPerId As Long

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstBuecher) Then Me.Recordset.FindFirst "buch_id=" & Me!lstBuecher

' Buchtitel im bergeordneten Formular anzeigen

Parent!txtBuchtitel = Me!txtTitel
Parent!lblGespeichert.Visible = False

' Ist dieses Buch bereits ausgeliehen?

If DCount("aus_id", "tblAusleihe", "buch_id_f=" & Str(lstBuecher) & _
                                  " AND aus_bis IS NULL") > 0 Then
   lngAusId = DLookup("aus_id", "tblAusleihe", "buch_id_f=" & Str(lstBuecher) & _
                                               " AND aus_bis IS NULL")
   lngPerId = DLookup("per_id_f", "tblAusleihe", "aus_id=" & Str(lngAusId))
   
   Parent!txtAusgeliehen.Caption = "Dieses Buch ist ausgeliehen seit dem " & _
         DLookup("aus_von", "tblAusleihe", "aus_id=" & Str(lngAusId)) & _
         " an: " & _
         DLookup("per_name", "tblPerson", "per_id=" & Str(lngPerId)) & _
         ", " & _
         DLookup("per_vorname", "tblPerson", "per_id=" & Str(lngPerId))
   Parent!txtAusgeliehen.Visible = True
   Parent!cmdSpeichern.Enabled = False
Else
   Parent!txtAusgeliehen.Visible = False
   Parent!cmdSpeichern.Enabled = True
End If

lstBuecher.SetFocus

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdBuchsuchen_Click()
'--------------------------------------------------------------
'ffne das Suchfenster

If errorhandling Then On Error GoTo fehlerbehandlung

Screen.PreviousControl.SetFocus
DoCmd.RunCommand acCmdFind

' Es ginge auch so:
' DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70
' Das ist aber ein veralteter Befehl, der schon in MS Access 97
' durch RunCommand ersetzt wurde.

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
' Anzeige des ersten Datensatzes in der Liste

If errorhandling Then On Error GoTo fehlerbehandlung

Me!lstBuecher.SetFocus
If Nz(lstBuecher.ListCount) > 0 Then   ' erste Zeile auswhlen
   Me!lstBuecher = Me!lstBuecher.ItemData(0)
   Call lstBuecher_AfterUpdate
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical
End Sub

========================================================
Code of the form 'frmAutoren_ufoBuecher'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmAutoren_ufoBuecher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtBuch_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmBuecher", , , , , , Me!buch_id
End Sub

Private Sub txtLager_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmLager", , , , , , Me!lager_id
End Sub

Private Sub txtOrt_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmOrte", , , , , , Me!ort_id
End Sub

========================================================
Code of the form 'frmLager_ufoBuecher'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmLager_ufoBuecher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtBuch_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmBuecher", , , , , , Me!buch_id
End Sub

========================================================
Code of the form 'frmRueckgabe_ufoBuecher'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmRueckgabe_ufoBuecher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtAusBis_AfterUpdate()
'--------------------------------------------------------------
'Fr den Fall, dass gerade nur die offenen Ausleihen angezeigt werden
'und der Nutzer ein Rckgabedatum eingetragen hat, muss das entsprechende
'Buch aus der Liste verschwinden. Darum muss die Liste aktualisiert werden.

If errorhandling Then On Error GoTo fehlerbehandlung

Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
'Eine Ausleihe lschen

Dim strMsgtext As String
Dim lngAntwort As Long
Dim strSQL As String
Dim rs As DAO.Recordset
Dim lngMahnIdf As Long

If errorhandling Then On Error GoTo fehlerbehandlung

strMsgtext = "Wollen Sie die Ausleihe des Buches" & vbCrLf & _
           Me!txtTitel & vbCrLf & "wirklich lschen?"
lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
If lngAntwort = vbNo Then Exit Sub

' Eine Ausleihe kann nicht ohne weiteres gelscht werden,
' weil es zu der Ausleihe noch Mahnungen geben kann.
' Die Verbindung zwischen Ausleihe und Mahnung geht ber die
' Zwischentabelle tblAus_Mahn.
' Wenn also eine bestimmte Ausleihe gelscht werden soll,
' muss zunchst der entsprechende Eintrag in tblAus_Mahn
' gelscht werden, dann die dazugehrigen Mahungen
' (u.U. mehrere!) und dann erst ganz zuletzt die Ausleihe!

strSQL = "SELECT mahn_id_f FROM tblAus_Mahn WHERE aus_id_f = " & Str(Me!aus_id)
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF   ' Lschen aller Mahnungen, die zu der zu lschenden Ausleihe gehren
   lngMahnIdf = rs!mahn_id_f
   rs.Delete   ' Lschen in der Zwischentabelle tblAus_Mahn (=RecordSet!)
   CurrentDb.Execute ("DELETE FROM tblMahnung WHERE mahn_id = " & Str(lngMahnIdf))
   rs.MoveNext
Loop
rs.Close
Set rs = Nothing

' Jetzt erst kann die Ausleihe gelscht werden!

CurrentDb.Execute ("DELETE FROM tblAusleihe WHERE aus_id=" & Str(Me!aus_id))
Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
'Beim ffnen des Formulars wird die Anzeige so eingestellt, dass
'nur die offenen Ausleihen angezeigt werden.

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1

lblVon.Caption = "seit:"
lblBis.Caption = "rck:"
tggAlleOffene = 0
tggAlleOffene.Caption = "alle Ausleihen anzeigen"
lblInfotext.Caption = "Sie knnen jetzt das Datum der Rckgabe eingeben!"
Me.Filter = "tblAusleihe.aus_bis is null"
Me.FilterOn = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub tggAlleOffene_Click()
'--------------------------------------------------------------
'Der Umschaltbutton wechselt die Anzeige zwischen "Nur die offenen Ausleihen"
'und "Alle Ausleihen"

'Der Umschaltbutton muss sich im Unterformular befinden, weil die Anwendung
'eines Filters auf ein Unterformular nicht funktioniert!
'Das geht also NICHT:
'Forms!frmRueckgabe!frmRueckgabe_ufoBuecher.Filter = "tblAusleihe.AUS_BIS is null"

'If umschalt_alleoffene = 0 Then
'   MsgBox "0"
'Else
'   MsgBox "-1"
'End If

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Filter = "tblAusleihe.aus_bis IS NULL"

If tggAlleOffene = 0 Then
'Das bedeutet, es werden nur die offenen Ausleihen angezeit.
   tggAlleOffene.Caption = "alle Ausleihen anzeigen"
   lblInfotext.Caption = "Sie knnen jetzt das Datum der Rckgabe eingeben!"
   txtAusVon.Locked = True
   txtAusBis.Locked = False
   lblVon.Caption = "seit:"
   lblBis.Caption = "rck:"
   Me.FilterOn = True
Else
'Das bedeutet, es werden alle Ausleihen angezeigt.
   tggAlleOffene.Caption = "nur offene Ausleihen anzeigen"
   lblInfotext.Caption = "Nur zur Ansicht!"
   txtAusVon.Locked = True
   txtAusBis.Locked = True
   lblVon.Caption = "von:"
   lblBis.Caption = "bis:"
   Me.FilterOn = False
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmVerlage_ufoBuecher'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmVerlage_ufoBuecher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtBuch_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmBuecher", , , , , , Me!buch_id
End Sub

Private Sub txtLager_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmLager", , , , , , Me!lager_id
End Sub

Private Sub txtOrt_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmOrte", , , , , , Me!ort_id
End Sub

========================================================
Code of the form 'frmZuweisung_ufoZugewiesen'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmZuweisung_ufozugewiesen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
'Es sollen nur die dem Buch bereits zugewiesenen Sachgebiete
'angezeigt werden.

'OpenArgs wird beim ffnen des Formulars "Zuweisung" bergeben
'und enthlt die buch_id des Buches, dem Sachgebiete zugewiesen
'werden sollen.

'MsgBox Parent.OpenArgs

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Filter = "buch_id_f = " & Parent.OpenArgs
Me.FilterOn = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmOrte_ufoLager'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmOrte_ufoLager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtLager_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmLager", , , , , , Me!lager_id
End Sub

========================================================
Code of the form 'frmRueckgabe'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmRueckgabe"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
' Anzeige des ersten Datensatzes in der Liste

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1

Me!lstPersonen.SetFocus
If Nz(lstPersonen.ListCount) > 0 Then   ' erste Zeile auswhlen
   Me!lstPersonen = Me!lstPersonen.ItemData(0)
   Call lstPersonen_AfterUpdate
End If

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtBemerkung_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtName_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtVorname_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstPersonen_AfterUpdate()
'--------------------------------------------------------------
'In der Liste ausgewhlten Datensatz anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstPersonen) Then Me.Recordset.FindFirst "per_id=" & Me!lstPersonen

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("rueckgabe")
End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
'Eine Person lschen

Dim lngAntwort As Long
Dim strMsgtext As String
Dim rs As DAO.Recordset
Dim strPervorname As String

If errorhandling Then On Error GoTo fehlerbehandlung

'Wurde ein zu lschender Datensatz ausgewhlt?
If IsNull(lstPersonen) Then
   MsgBox "Bitte whlen Sie die zu lschende Person aus der Liste!"
   lstPersonen.SetFocus
   Exit Sub
End If

If Nz(Me!txtVorname) = "" Then
   strPervorname = ""
Else
   strPervorname = Me!txtVorname
End If

strMsgtext = "Wollen Sie " & strPervorname & " " & Me!txtName & " wirklich lschen?"

'Gibt es noch Datenstze in anderen Tabellen, die mit dem zu lschenden
'Datensatz in Beziehung stehen ?

Set rs = CurrentDb.OpenRecordset("tblAusleihe", dbOpenDynaset)
rs.FindFirst "per_id_f=" & Str(Me!per_id)

If rs.NoMatch Then
   lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
   rs.Close
   Set rs = Nothing
   If lngAntwort = vbNo Then Exit Sub
   CurrentDb.Execute "DELETE FROM tblKontakt WHERE per_id_f=" & Str(Me!per_id)
   CurrentDb.Execute "DELETE FROM tblPerson WHERE per_id=" & Str(Me!per_id)
   lstPersonen.Requery
   Requery
   Me!lstPersonen.SetFocus
   
   If Nz(lstPersonen.ListCount) > 0 Then   ' erste Zeile auswhlen
      Me!lstPersonen = Me!lstPersonen.ItemData(0)
      Call lstPersonen_AfterUpdate
   End If
   
Else
   MsgBox "Diese Person kann nicht gelscht werden!" & vbCrLf & _
          "Sie hat noch ausgeliehene Bcher."
   rs.Close
   Set rs = Nothing
   Exit Sub
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------
Dim lngPerId As Long

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtName) = "" Then
   MsgBox "Bitte geben Sie einen Nachnamen ein!"
   txtName.SetFocus
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord   ' Speichern des bearbeiteten Datensatzes
lngPerId = Me!per_id               ' Primrschlssel merken

lstPersonen.Enabled = True
lstPersonen.Requery                ' Refresh der Auswahlliste
lstPersonen.SetFocus
lstPersonen = lngPerId             ' Anzeige des gespeicherten Datensatzes
Call lstPersonen_AfterUpdate       ' Trick 17: Click-Simulation!!

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdNeu_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

lstPersonen = Null

DoCmd.GoToRecord , , acNewRec
txtName.SetFocus

cmdLoeschen.Enabled = False
cmdNeu.Enabled = False
lstPersonen.Enabled = False

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmHilfe'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmHilfe"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdSchliessen_Click()
DoCmd.Close
End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
' Dies ist eine ganz allgemeine Prozedur zur Anzeige irgendwelcher
' Hilfe-Dateien. Der Name der konkret zu ffnenden Datei wird
' mit dem Parameter OpenArgs bergeben (siehe in der aufrufenden
' Prozedur)

If errorhandling Then On Error GoTo fehlerbehandlung

Dim objFso As Object
Dim objF As Object
Dim objTs As Object
Dim lngFiletype As Long

If IsNull(Me.OpenArgs) Then Exit Sub

' Der zweite Parameter der Funktion OpenAsTextStream hngt vom Format
' der zu ffnenden Datei ab.

' Der Wert der Konstanten "Accessversion" wird so gesetzt:
' In VBA: Extras / Eigenschaften von ...
' Dort unter "Argumente fr die bedingte Kompilierung"
' Will man dort mehrere Konstanten definieren,
' so mssen sie durch Doppelpunkte voneinander getrennt werden!

Select Case Right(Me.OpenArgs, 3)
   Case "txt"                         ' Access 2000/2003
      lngFiletype = 0
      #If Accessversion > 2003 Then
         txtHilfetext.TextFormat = acTextFormatPlain
      #End If
   Case "rtf"                         ' Access 2007/2010
      lngFiletype = -1
      #If Accessversion > 2003 Then
         txtHilfetext.TextFormat = acTextFormatHTMLRichText
      #End If
   Case Else
      MsgBox "Unbekannter Dateityp der Hilfedatei!"
      Exit Sub
End Select

' Hilfedatei ffnen und anzeigen

Set objFso = CreateObject("Scripting.FileSystemObject")
Set objF = objFso.GetFile(Me.OpenArgs)
Set objTs = objF.OpenAsTextStream(1, lngFiletype)

Me.txtHilfetext = objTs.ReadAll
'Me!txtHilfetext.Locked = True
cmdSchliessen.SetFocus

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmAusleihe_ufoPersonen'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmAusleihe_ufoPersonen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdPersonsuchen_Click()
'--------------------------------------------------------------
'ffne das Suchfenster

If errorhandling Then On Error GoTo fehlerbehandlung

Screen.PreviousControl.SetFocus
DoCmd.RunCommand acCmdFind

' Es ginge auch so:
' DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70
' Das ist aber ein veralteter Befehl, der schon in MS Access 97
' durch RunCommand ersetzt wurde.

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
' Anzeige des ersten Datensatzes in der Liste

If errorhandling Then On Error GoTo fehlerbehandlung

'Me!lstPersonen.SetFocus
'If Nz(lstPersonen.ListCount) > 0 Then   ' erste Zeile auswhlen
'   Me!lstPersonen = Me!lstPersonen.ItemData(0)
'   Call lstPersonen_AfterUpdate
'End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical
   
End Sub

Private Sub lstPersonen_AfterUpdate()
'--------------------------------------------------------------
'Die Daten des in der Liste angeclickten Datensatzes anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstPersonen) Then Me.Recordset.FindFirst "per_id=" & Me!lstPersonen

'Name und Nachname im bergeordneten Formular anzeigen

Parent!txtNachname = Me!txtName
Parent!txtVorname = Me!txtVorname

Parent!lblGespeichert.Visible = False

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmBuecher_ufoAutoren'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmBuecher_ufoAutoren"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtName_DblClick(Cancel As Integer)
DoCmd.OpenForm "frmAutoren", , , , , , Me!autor_id
End Sub

========================================================
Code of the form 'frmRueckgabe_ufoKontakte'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmRueckgabe_ufoKontakte"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cboKontakttyp_AfterUpdate()
'--------------------------------------------------------------
' Durch die nderung des Wertes in einem Kombinationsfeld wird eine
' Transaktion (nderung von Daten in der Datenbank) begonnen
' (erkennbar am Schreibstift im Datensatzmarkierer!).
' Da eine nicht ordnungsgem beendete Transaktion zu Fehlern fhren kann,
' wird die gerade begonnene Transaktion auch sofort wieder durch einen
' "Speichern"-Befehl beendet.

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.RunCommand (acCmdSaveRecord)

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboKontakttyp_Dirty(Cancel As Integer)
'--------------------------------------------------------------
' Sicherheitsmanahme gegen versehentliches ndern von Daten durch
' Clicken in ein Kombinationsfeld
' Beim erstmaligen Eintrag von Daten (OldValue=Null) wird nicht nachgefragt.

If errorhandling Then On Error GoTo fehlerbehandlung

If IsNull(cboKontakttyp.OldValue) Then Exit Sub
If MsgBox("Wollen Sie den Kontakttyp wirklich ndern?", vbYesNo + vbDefaultButton2) = vbNo Then
   Cancel = True       ' Abbruch der Bearbeitung
   SendKeys ("{ESC}")  ' Schlieen der Combobox
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboKontakttyp_GotFocus()
'--------------------------------------------------------------
' Wenn der Inhalt der Combobox in einem anderen Formular gendert wurde,
' soll die nderung hier sofort sichtbar werden

If errorhandling Then On Error GoTo fehlerbehandlung

cboKontakttyp.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
'Einen Kontakt lschen

Dim strMsgtext As String
Dim lngAntwort As Long

If errorhandling Then On Error GoTo fehlerbehandlung

'In der letzten Zeile kann ein neuer Kontakt eingegeben werden.
'Dort darf nicht gelscht werden.

If IsNull(txtKontakt) Then Exit Sub

'Sicherheitsabfrage

strMsgtext = "Wollen Sie den Kontakt" & vbCrLf & _
           Me!txtKontakt & vbCrLf & "wirklich lschen?"
lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
If lngAntwort = vbNo Then Exit Sub

CurrentDb.Execute ("DELETE FROM tblKontakt WHERE kon_id=" & Str(Me!kon_id))
Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_BeforeDelConfirm(Cancel As Integer, Response As Integer)
' Mit dem folgenden Befehl wird verhindert, dass sich die Standardwarnung
' "Sie sind dabei, 1 Datenstze zu lschen ..." zustzlich zu der selbst programmierten
' Warnung in Form_Delete auch noch ffnet!

If errorhandling Then On Error GoTo fehlerbehandlung

Response = acDataErrContinue

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtKontakt) = "" Then
   MsgBox "Bitte geben Sie die Kontaktdaten ein!"
   txtKontakt.SetFocus
   Cancel = True
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Delete(Cancel As Integer)
'--------------------------------------------------------------
' Diese Prozedur wird ausgefhrt, wenn im Formular ein Datensatz ausgewhlt und
' auf "Entf." gedrckt wird - aber noch BEVOR das eigentliche Lschen erfolgt.
' Indem man den Parameter "Cancel" auf True setzt, kann man das Lschen verhindern.

If errorhandling Then On Error GoTo fehlerbehandlung

If MsgBox("Wollen Sie den Kontakt wirklich lschen?", vbYesNo + _
           vbDefaultButton2) = vbNo Then Cancel = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
Me.Cycle = 1
End Sub

========================================================
Code of the form 'frmZuweisung'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmZuweisung"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

'Dieses Formular kann nicht alleine, sondern nur vom Formular
'"Bcher erfassen" aus geffnet werden.

Private Sub cmdDazu_Click()
'--------------------------------------------------------------
'Fge ein Sachgebiet zu dem Buch hinzu

If errorhandling Then On Error GoTo fehlerbehandlung

Dim vntVorhanden As Variant

vntVorhanden = DCount("buch_id_f", "tblBuch_Sach", "buch_id_f=" & OpenArgs & _
                   " and sachgebiet='" & Me!txtSachgebiet & "'")
If vntVorhanden > 0 Then Exit Sub

CurrentDb.Execute ("INSERT INTO tblBuch_Sach(sachgebiet, buch_id_f) VALUES ('" & _
                   Me!txtSachgebiet & "'," & OpenArgs & ")")
Forms!frmZuweisung!frmZuweisung_ufoZugewiesen.Requery
Forms!frmBuecher!frmBuecher_ufoSachgebiete.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
'--------------------------------------------------------------
'Hilfe-Datei anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

Dim strDateiname As String
Dim objFso As Object

strDateiname = Application.CurrentProject.Path & "\hilfe-zuweisung"

' In Access 2003 (= Version 11.0) knnen Textboxen keine .rtf-Daten darstellen.
' Darum dort nur .txt-Dateien als Hilfedateien!

If Application.version < "12.0" Then     ' Access 2000/2003
   strDateiname = strDateiname & ".txt"
Else                                     ' Access 2007
   strDateiname = strDateiname & ".rtf"
End If

Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FileExists(strDateiname) Then
   DoCmd.OpenForm "Hilfe", , , , , , strDateiname
Else
   MsgBox "Fr dieses Formular existiert leider keine Hilfe-Information."
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdObersachgebiet_Click()
'--------------------------------------------------------------
' Mache das Obersachgebiet des aktuellen Sachgebietes zum aktuellen Sachgebiet
' (Oder, mit anderen Worten: Gehe im Sachgebietsbaum einen Schritt zurck)

If errorhandling Then On Error GoTo fehlerbehandlung

Dim rs As DAO.Recordset

Set rs = Me.Recordset.Clone
rs.FindFirst "sachgebiet='" & Me!OBERSACHGEBIET & "'"
If Not rs.EOF Then Me.Bookmark = rs.Bookmark
rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdOberstesSachgebiet_Click()
'--------------------------------------------------------------
' Zurck zum obersten Sachgebiet

If errorhandling Then On Error GoTo fehlerbehandlung

Dim rs As DAO.Recordset
Dim strOberstesSachgebiet As String

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = obersachgebiet"
strOberstesSachgebiet = rs!SACHGEBIET
rs.Close
Set rs = Nothing

Set rs = Me.Recordset.Clone
rs.FindFirst "sachgebiet = '" & strOberstesSachgebiet & "'"
If Not rs.EOF Then Me.Bookmark = rs.Bookmark
rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdWeg_Click()
'--------------------------------------------------------------
'Entferne die Zuordnung eines Sachgebietes zu einem Buch

If errorhandling Then On Error GoTo fehlerbehandlung

Dim strSachgebiet As String

strSachgebiet = Forms!frmZuweisung!frmZuweisung_ufoZugewiesen!txtSachgebiet

CurrentDb.Execute ("DELETE FROM tblBuch_Sach WHERE sachgebiet='" & strSachgebiet & _
                   "' and buch_id_f=" & OpenArgs)
Forms!frmZuweisung!frmZuweisung_ufoZugewiesen.Requery
Forms!frmBuecher!frmBuecher_ufoSachgebiete.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
Dim rs As DAO.Recordset
Dim strOberstesSachgebiet As String

'Dieses Formular kann nicht unabhngig geffnet werden, sondern nur
'vom Formular "Bcher" aus durch Click auf den Button "Sachgebiete".
'Dabei wird als ffnungsargument buch_id begeben.
'Dieses wird verwendet, um den Buchtitel anzuzeigen, dem Sachgebiete
'zugewiesen werden sollen.

If errorhandling Then On Error GoTo fehlerbehandlung

txtBuchtitel = DLookup("buch_titel", "tblBuch", "buch_id=" & OpenArgs)

'Zeige nach dem ffnen das oberste Sachgebiet an!

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = obersachgebiet"

If rs.NoMatch Then
   MsgBox "Es gibt kein Sachgebiet, bei dem sachgebiet=obersachgebiet ist" & vbCrLf & _
          "(oberstes Sachgebiet). Bitte legen Sie ein solches Sachgebiet an," & vbCrLf & _
          "sonst wird dieses Formular nicht funktionieren!"
   rs.Close
   Set rs = Nothing
   Exit Sub
End If

strOberstesSachgebiet = rs!SACHGEBIET
rs.Close
Set rs = Nothing

' ... oder auch so:
' strOberstesSachgebiet = DLookup("sachgebiet", "tblSachgebiet", "sachgebiet = obersachgebiet")
' Achtung: strOberstesSachgebiet muss dann vom Typ Variant sein!

Set rs = Me.Recordset.Clone
rs.FindFirst "sachgebiet = '" & strOberstesSachgebiet & "'"
If Not rs.EOF Then Me.Bookmark = rs.Bookmark
rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstSachgebiete_AfterUpdate()
'--------------------------------------------------------------
'Die Daten des in der Liste angeclickten Datensatzes anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstSachgebiete) Then Me.Recordset.FindFirst "sachgebiet='" & Me!lstSachgebiete & "'"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmBuecher'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmBuecher"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cboLager_AfterUpdate()
'--------------------------------------------------------------
' Durch die nderung des Wertes in einem Kombinationsfeld wird eine
' Transaktion (nderung von Daten in der Datenbank) begonnen
' (erkennbar am Schreibstift im Datensatzmarkierer!).
' Da eine nicht ordnungsgem beendete Transaktion zu Fehlern fhren kann,
' wird die gerade begonnene Transaktion auch sofort wieder durch einen
' "Speichern"-Befehl beendet.

DoCmd.RunCommand (acCmdSaveRecord)

End Sub

Private Sub cboLager_Dirty(Cancel As Integer)
'--------------------------------------------------------------
' Sicherheitsmanahme gegen versehentliches ndern von Daten durch
' Clicken in ein Kombinationsfeld
' Beim erstmaligen Eintrag von Daten (OldValue=Null) wird nicht nachgefragt.

If errorhandling Then On Error GoTo fehlerbehandlung

If IsNull(cboLager.OldValue) Then Exit Sub
If MsgBox("Wollen Sie das Lager wirklich ndern?", vbYesNo + vbDefaultButton2) = vbNo Then
   Cancel = True       ' Abbruch der Bearbeitung
   SendKeys ("{ESC}")  ' Schlieen der Combobox
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboLager_GotFocus()
'--------------------------------------------------------------
' Wenn der Inhalt der Combobox in einem anderen Formular gendert wurde,
' soll die nderung hier sofort sichtbar werden

If errorhandling Then On Error GoTo fehlerbehandlung

cboLager.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboVerlag_AfterUpdate()
'--------------------------------------------------------------
' Durch die nderung des Wertes in einem Kombinationsfeld
' wird eine Transaktion (nderung von Daten in der Datenbank)
' begonnen(erkennbar am Schreibstift im Datensatzmarkierer!).
' Da eine nicht ordnungsgem beendete Transaktion zu Fehlern
' fhren kann, wird die gerade begonnene Transaktion auch
' sofort wieder durch einen "Speichern"-Befehl beendet.

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.RunCommand (acCmdSaveRecord)

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboVerlag_Dirty(Cancel As Integer)
'--------------------------------------------------------------
' Sicherheitsmanahme gegen versehentliches ndern von Daten
' durch Clicken in ein Kombinationsfeld
' Beim erstmaligen Eintrag von Daten (OldValue=Null)
' wird nicht nachgefragt.

If errorhandling Then On Error GoTo fehlerbehandlung

If IsNull(cboVerlag.OldValue) Then Exit Sub
If MsgBox("Wollen Sie den Verlag wirklich ndern?", _
           vbYesNo + vbDefaultButton2) = vbNo Then
   Cancel = True       ' Abbruch der Bearbeitung
   SendKeys ("{ESC}")  ' Schlieen der Combobox
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboVerlag_GotFocus()
'--------------------------------------------------------------
' Wenn der Inhalt des Kombinationsfeldes in einem ANDEREN Formular
' gendert wurde, soll die nderung hier sofort sichtbar werden

If errorhandling Then On Error GoTo fehlerbehandlung

cboVerlag.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboZustand_AfterUpdate()
'--------------------------------------------------------------
' Durch die nderung des Wertes in einem Kombinationsfeld wird eine
' Transaktion (nderung von Daten in der Datenbank) begonnen
' (erkennbar am Schreibstift im Datensatzmarkierer!).
' Da eine nicht ordnungsgem beendete Transaktion zu Fehlern fhren kann,
' wird die gerade begonnene Transaktion auch sofort wieder durch einen
' "Speichern"-Befehl beendet.

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.RunCommand (acCmdSaveRecord)

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboZustand_GotFocus()
'--------------------------------------------------------------
' Wenn der Inhalt der Combobox in einem anderen Formular gendert wurde,
' soll die nderung hier sofort sichtbar werden

If errorhandling Then On Error GoTo fehlerbehandlung

cboZustand.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstAutoren_GotFocus()
lstAutoren.Requery
End Sub

Private Sub txtBemerkung_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtTitel_BeforeUpdate(Cancel As Integer)
' Ist das Eingabefeld leer?
' Cancel = True bewirkt, dass das Update NICHT ausgefhrt wird,
' was in diesem Fall bedeutet, dass der Inhalt des Eingabefeldes
' nicht gelscht wird!
' Das Drcken der Esc-Taste bewirkt, dass ein gelschter Wert
' wieder hergestellt wird.
' Summa summarun wird alo verhindert, dass der Datensatz mit
' einem leeren Eingabefeld gespeichert wird!

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(Me!txtTitel) = "" Then
   MsgBox "Bitte geben Sie einen Titel ein oder drcken Sie die Esc-Taste!"
   Cancel = True
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtTitel_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtNummer_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtJahr_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstBuecher_AfterUpdate()
'--------------------------------------------------------------
'Die Daten des in der Liste angeclickten Datensatzes anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstBuecher) Then Me.Recordset.FindFirst "buch_id=" & Me!lstBuecher

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

' Jetzt knnen Autoren zugewiesen werden

cmdRueber.Enabled = True
cmdZurueck.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("buecher")
End Sub

Private Sub cmdRueber_Click()
'--------------------------------------------------------------
'Einen Autor zum Buch hinzufgen
Dim strSQL As String

If errorhandling Then On Error GoTo fehlerbehandlung

'Wurde in der rechten Liste ein Autor angeclickt?

If IsNull(lstAutoren) Then
   MsgBox "Bitte whlen Sie einen Autor aus der rechten Liste!"
   Exit Sub
End If

' KANN WEG! Vorsorge in cmdNeu_Click!

' Wenn der Nutzer den Button "neu" drckt, einige Buchdaten eingibt
' und dann einen Autor zuweisen will, so geht das nicht, weil sich das neue
' Buch noch nicht in der Tabelle tblBuch befindet, d.h. es hat noch keinen Wert
' fr buch_id. Dann kann auch kein Eintrag in die Tabelle BUCH_AUTOR erfolgen.
' Daher muss das neue Buch erst einmal gespeichert werden.

'If Nz(txtTitel)="" Then
'   MsgBox "Bitte geben Sie einen Titel ein!"
'   txtTitel.SetFocus
'   Exit Sub
'End If
'
'DoCmd.RunCommand acCmdSaveRecord
'lstBuecher.Requery

'Wurde der in der Autorenliste angeclickte Autor dem Buch bereits zugewiesen?

If DCount("buch_id_f", "tblAutor_Buch", "buch_id_f=" & Str(Me!buch_id) & _
          " AND autor_id_f=" & Str(lstAutoren)) > 0 Then Exit Sub

'Wenn nicht, dann erfolgt jetzt die Zuweisung

strSQL = "INSERT INTO tblAutor_Buch (buch_id_f, autor_id_f) " & _
         "VALUES (" & Str(Me!buch_id) & "," & Str(lstAutoren) & ")"
'MsgBox strSQL
CurrentDb.Execute strSQL
Forms!frmBuecher!frmBuecher_ufoAutoren.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSachgebiete_Click()
'--------------------------------------------------------------
' Wenn der Nutzer den Button "Buch hinzufgen" drckt, einige Buchdaten eingibt
' und dann Sachgebiete zuweisen will, so geht das nicht, weil sich das neue
' Buch noch nicht in der Tabelle tblBuch befindet, d.h. es hat noch keinen Wert
' fr buch_id. Dann kann auch kein Eintrag in die Tabelle tblBuch_Sach erfolgen.
' Daher muss das neue Buch erst einmal gespeichert werden.

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtTitel) = "" Then
   MsgBox "Bitte geben Sie einen Titel ein!"
   txtTitel.SetFocus
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord
lstBuecher.Requery

'... und jetzt knnen Sachgebiete zugewiesen werden!
DoCmd.OpenForm "frmZuweisung", , , , , , Str(Me!buch_id)

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub
Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
'Ein Buch lschen
'(alternative Technik in frmOrte!)

Dim lngAntwort As Long
Dim strMsgtext As String
Dim rs As DAO.Recordset

If errorhandling Then On Error GoTo fehlerbehandlung

'Wurde ein zu lschender Datensatz ausgewhlt?

If IsNull(lstBuecher) Then
   MsgBox "Bitte whlen Sie das zu lschende Buch aus der Liste!"
   lstBuecher.SetFocus
   Exit Sub
End If

strMsgtext = "Wollen Sie das Buch " & vbCrLf & Me!BUCH_TITEL & vbCrLf & " wirklich lschen?"

' Ist das Buch noch ausgeliehen?

Set rs = CurrentDb.OpenRecordset("tblAusleihe", dbOpenDynaset)
rs.FindFirst "buch_id_f=" & Str(Me!buch_id) & " AND aus_bis IS NULL"

If rs.NoMatch Then
   lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
   If lngAntwort = vbYes Then
      CurrentDb.Execute "DELETE FROM tblAusleihe WHERE buch_id_f=" & Str(Me!buch_id)
      CurrentDb.Execute "DELETE FROM tblAutor_Buch WHERE buch_id_f=" & Str(Me!buch_id)
      CurrentDb.Execute "DELETE FROM tblBuch_Sach WHERE buch_id_f=" & Str(Me!buch_id)
      CurrentDb.Execute "DELETE FROM tblBuch WHERE buch_id=" & Str(Me!buch_id)
  
      Requery
      lstBuecher.Requery
      lstBuecher = Me!buch_id
      
      Me!lstBuecher.SetFocus
      If Nz(lstBuecher.ListCount) > 0 Then   ' erste Zeile auswhlen
         Me!lstBuecher = Me!lstBuecher.ItemData(0)
         Call lstBuecher_AfterUpdate
      End If
   
   End If
Else
   MsgBox "Dieses Buch kann nicht gelscht werden," & vbCrLf & _
          "weil es noch ausgeliehen ist!"
End If

rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub
Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------
Dim lngBuchId As Long

'Hat der Nutzer alle erforderlichen Daten eingegeben?

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtTitel) = "" Then
   MsgBox "Bitte geben Sie einen Titel ein!"
   txtTitel.SetFocus
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord
lngBuchId = Me!buch_id

' Jetzt knnen Autoren zugewiesen werden

cmdRueber.Enabled = True
cmdZurueck.Enabled = True

lstBuecher.Enabled = True
lstBuecher.Requery
lstBuecher.SetFocus
lstBuecher = lngBuchId
Call lstBuecher_AfterUpdate

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub
Private Sub cmdNeu_Click()
'--------------------------------------------------------------
'Ein neues Buch anlegen

If errorhandling Then On Error GoTo fehlerbehandlung

lstBuecher = Null
DoCmd.GoToRecord , , acNewRec
txtTitel.SetFocus

cmdLoeschen.Enabled = False
cmdNeu.Enabled = False
lstBuecher.Enabled = False

' Wenn der Nutzer den Button "neu" drckt, einige Buchdaten eingibt
' und dann einen Autor zuweisen will, so geht das nicht, weil sich das neue
' Buch noch nicht in der Tabelle tblBuch befindet, d.h. es hat noch keinen Wert
' fr buch_id. Dann kann auch kein Eintrag in die Tabelle BUCH_AUTOR erfolgen.
' Daher muss das neue Buch erst einmal gespeichert werden.

cmdRueber.Enabled = False
cmdZurueck.Enabled = False

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdZurueck_Click()
'--------------------------------------------------------------
'Einen Autor aus der Liste der Autoren des Buches entfernen

Dim lngAutorId As Long

If errorhandling Then On Error GoTo fehlerbehandlung

lngAutorId = Forms!frmBuecher!frmBuecher_ufoAutoren!autor_id
CurrentDb.Execute "DELETE FROM tblAutor_Buch WHERE " & _
                  "autor_id_f=" & Str(lngAutorId) & " AND " & _
                  "buch_id_f=" & Str(Me!buch_id)
Forms!frmBuecher!frmBuecher_ufoAutoren.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cboZustand_Dirty(Cancel As Integer)
'--------------------------------------------------------------
' Sicherheitsmanahme gegen versehentliches ndern von Daten durch
' Clicken in ein Kombinationsfeld
' Beim erstmaligen Eintrag von Daten (OldValue=Null) wird nicht nachgefragt.

If IsNull(cboZustand.OldValue) Then Exit Sub
If MsgBox("Wollen Sie den Zustand wirklich ndern?", vbYesNo + vbDefaultButton2) = vbNo Then
   Cancel = True       ' Abbruch der Bearbeitung
   SendKeys ("{ESC}")  ' Schlieen der Combobox
End If
End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1
Me!lstBuecher.SetFocus
   
' Wenn das Formular mittels Doppelclick von einem anderen Formular aus geffnet wird,
' soll der dort angeclickte Datensatz angezeigt werden.
' Ansonsten soll der erste Datensatz angezeigt werden.

If IsNull(OpenArgs) Then   ' Anzeige des ersten Buches in der Liste

   If Nz(lstBuecher.ListCount) > 0 Then   ' erste Zeile auswhlen
      Me!lstBuecher = Me!lstBuecher.ItemData(0)
      Call lstBuecher_AfterUpdate
   End If

Else    ' Anzeige des in einem anderen Formular angeclickten Buches
   Me!lstBuecher = OpenArgs
   Call lstBuecher_AfterUpdate
End If

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmVerlage2'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmVerlage2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
' Anzeige des ersten Datensatzes in der Liste

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1

Me!lstVerlage.SetFocus
If Nz(lstVerlage.ListCount) > 0 Then   ' erste Zeile auswhlen
   Me!lstVerlage = Me!lstVerlage.ItemData(0)
   Call lstVerlage_AfterUpdate
End If

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtBemerkung_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtName_BeforeUpdate(Cancel As Integer)
' Ist das Eingabefeld leer?
' Cancel = True bewirkt, dass das Update NICHT ausgefhrt wird,
' was in diesem Fall bedeutet, dass der Inhalt des Eingabefeldes
' nicht gelscht wird!
' Das Drcken der Esc-Taste bewirkt, dass ein gelschter Wert
' wieder hergestellt wird.
' Summa summarun wird alo verhindert, dass der Datensatz mit
' einem leeren Eingabefeld gespeichert wird!

'If errorhandling Then On Error GoTo fehlerbehandlung
'
'If Nz(Me!txtName) = "" Then
'   MsgBox "Bitte geben Sie einen Namen ein oder drcken Sie die Esc-Taste!"
'   Cancel = True
'End If
'
'Exit Sub
'fehlerbehandlung:
'   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtName_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtOrt_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstVerlage_AfterUpdate()
'--------------------------------------------------------------
'Den in der Liste ausgewhlten Datensatz anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstVerlage) Then Me.Recordset.FindFirst "ver2_id=" & Me!lstVerlage

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True
lstVerlage.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("verlage")
End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
'Einen Verlag lschen
' (alternative Technik in frmOrte!)

Dim lngAntwort As Long
Dim strMsgtext As String
Dim rs As DAO.Recordset

If errorhandling Then On Error GoTo fehlerbehandlung

'Wurde ein zu lschender Datensatz ausgewhlt?

If IsNull(lstVerlage) Then
   MsgBox "Bitte whlen Sie den zu lschenden Verlag aus der Liste!"
   lstVerlage.SetFocus
   Exit Sub
End If

strMsgtext = "Wollen Sie den Verlag " & Me!ver2_name & " wirklich lschen?"

'Gibt es noch Datenstze in anderen Tabellen, die mit dem zu lschenden
'Datensatz in Beziehung stehen ?

Set rs = CurrentDb.OpenRecordset("tblBuch", dbOpenDynaset)
rs.FindFirst "ver_id_f=" & Str(Me!ver2_id)

If rs.NoMatch Then
   lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
   If lngAntwort = vbYes Then
      CurrentDb.Execute "DELETE FROM tblVerlag2 WHERE ver2_id=" & Str(Me!ver2_id)
      lstVerlage.Requery
      Requery

      Me!lstVerlage.SetFocus
      If Nz(lstVerlage.ListCount) > 0 Then   ' erste Zeile auswhlen
         Me!lstVerlage = Me!lstVerlage.ItemData(0)
         Call lstVerlage_AfterUpdate
      End If
      
   End If
Else
   MsgBox "Dieser Verlag kann nicht gelscht werden!" & vbCrLf & _
          "Es gibt noch Bcher von ihm."
End If

rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------
Dim lngVerId As Long

'Hat der Nutzer alle erforderlichen Daten eingegeben?

If errorhandling Then On Error GoTo fehlerbehandlung

' Die folgenden Zeilen habe ich absichtlich auskommentiert.
' Sie wrden nmlich das Entstehen von "Geisterdaten" verhindern.
' Wenn Sie also tatschlich Tabellen ohne Muss-Felder haben,
' mssen Sie selbst dafr sorgen,
' dass ENTWEDER bestimmte Felder im Formular ausgefllt werden
' ODER dass keine Speicherung erfolgt, wenn alle Eingabefelder leer sind.

'If Nz(txtName) = "" Then
'   MsgBox "Bitte geben Sie einen Namen ein!"
'   txtName.SetFocus
'   Exit Sub
'End If

' Gibt es diesen Verlag schon?

If (txtName <> txtName.OldValue Or _
    IsNull(txtName.OldValue)) And _
   DCount("ver2_id", "tblVerlag2", "ver2_name='" & txtName & "'") > 0 Then
   MsgBox ("Diesen Verlag gibt es schon!")
   Me.Undo   ' Abbrechen der begonnenen Transaktion (Datensatzmarkierer beobachten!!)
   txtName.SetFocus
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord
'lngVerId = Me!ver2_id

lstVerlage.Enabled = True
lstVerlage.Requery
lstVerlage.SetFocus
cmdNeu.Enabled = True
cmdLoeschen.Enabled = True

' Anzeige des gespeicherten Verlages

'lstVerlage = lngVerId
'Call lstVerlage_AfterUpdate

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdNeu_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

lstVerlage = Null
DoCmd.GoToRecord , , acNewRec
txtName.SetFocus

cmdLoeschen.Enabled = False
cmdNeu.Enabled = False
'lstVerlage.Enabled = False

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmBuechersuche_ufoUntersachgebiete'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmBuechersuche_ufoUntersachgebiete"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtSachgebiet_Click()
'--------------------------------------------------------------
'Mache das angeclickte Untersachgebiet zum aktuellen Sachgebiet
'und zeige die dazugehrigen Bcher an.

Dim strSQL As String

If errorhandling Then On Error GoTo fehlerbehandlung

Parent!txtAktuellesSachgebiet = txtSachgebiet

'Die Filterung sorgt dafr, dass im Unterformular die zum aktuellen
'Sachgebiet gehrenden Untersachgebiete angezeigt werden.

Parent.Filter = "tblSachgebiet.sachgebiet='" & txtSachgebiet & "'"
Parent.FilterOn = True
Parent!txtAktuellesSachgebiet.SetFocus

'Zeige in der Bcherliste die Bcher zum aktuellen Sachgebiet an

strSQL = "SELECT tblBuch.buch_id, tblBuch.buch_titel " & _
         "FROM tblBuch_Sach INNER JOIN tblBuch " & _
         "ON tblBuch.buch_id = tblBuch_Sach.buch_id_f " & _
         "WHERE tblBuch_Sach.sachgebiet ='" & Parent!txtAktuellesSachgebiet & "'" & _
         " ORDER BY tblBuch.buch_titel"

Parent!lstBuecher.RowSourceType = "Table/Query"
Parent!lstBuecher.RowSource = strSQL

Parent!lstBuecher.SetFocus
If Nz(Parent!lstBuecher.ListCount) > 0 Then   ' erste Zeile auswhlen
   Parent!lstBuecher = Parent!lstBuecher.ItemData(0)
   Call Parent.public_lstBuecher_AfterUpdate
Else
   Call Parent.Public_BuchdatenLoeschen
End If

Parent!lstSachgebiete = Null

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmVerlage'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmVerlage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
' Anzeige des ersten Datensatzes in der Liste

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1

Me!lstVerlage.SetFocus
If Nz(lstVerlage.ListCount) > 0 Then   ' erste Zeile auswhlen
   Me!lstVerlage = Me!lstVerlage.ItemData(0)
   Call lstVerlage_AfterUpdate
End If

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtBemerkung_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtName_BeforeUpdate(Cancel As Integer)
' Ist das Eingabefeld leer?
' Cancel = True bewirkt, dass das Update NICHT ausgefhrt wird,
' was in diesem Fall bedeutet, dass der Inhalt des Eingabefeldes
' nicht gelscht wird!
' Das Drcken der Esc-Taste bewirkt, dass ein gelschter Wert
' wieder hergestellt wird.
' Summa summarun wird alo verhindert, dass der Datensatz mit
' einem leeren Eingabefeld gespeichert wird!

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(Me!txtName) = "" Then
   MsgBox "Bitte geben Sie einen Namen ein oder drcken Sie die Esc-Taste!"
   Cancel = True
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtName_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtOrt_Change()
'--------------------------------------------------------------
'Wenn der Nutzer eine Eingabe gemacht hat, soll der
'Speichern-Button zum Standard-Button werden.
'Das bedeutet, der Nutzer kann nach der Dateneingabe
'einfach die Enter-Taste drcken.

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Default = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstVerlage_AfterUpdate()
'--------------------------------------------------------------
'Den in der Liste ausgewhlten Datensatz anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstVerlage) Then Me.Recordset.FindFirst "ver_id=" & Me!lstVerlage

cmdLoeschen.Enabled = True
cmdNeu.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("verlage")
End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub
Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
'Einen Verlag lschen
' (alternative Technik in frmOrte!)

Dim lngAntwort As Long
Dim strMsgtext As String
Dim rs As DAO.Recordset

If errorhandling Then On Error GoTo fehlerbehandlung

'Wurde ein zu lschender Datensatz ausgewhlt?

If IsNull(lstVerlage) Then
   MsgBox "Bitte whlen Sie den zu lschenden Verlag aus der Liste!"
   lstVerlage.SetFocus
   Exit Sub
End If

strMsgtext = "Wollen Sie den Verlag " & Me!VER_NAME & " wirklich lschen?"

'Gibt es noch Datenstze in anderen Tabellen, die mit dem zu lschenden
'Datensatz in Beziehung stehen ?

Set rs = CurrentDb.OpenRecordset("tblBuch", dbOpenDynaset)
rs.FindFirst "ver_id_f=" & Str(Me!ver_id)

If rs.NoMatch Then
   lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
   If lngAntwort = vbYes Then
      CurrentDb.Execute "DELETE FROM tblVerlag WHERE ver_id=" & Str(Me!ver_id)
      lstVerlage.Requery
      Requery

      Me!lstVerlage.SetFocus
      If Nz(lstVerlage.ListCount) > 0 Then   ' erste Zeile auswhlen
         Me!lstVerlage = Me!lstVerlage.ItemData(0)
         Call lstVerlage_AfterUpdate
      End If
      
   End If
Else
   MsgBox "Dieser Verlag kann nicht gelscht werden!" & vbCrLf & _
          "Es gibt noch Bcher von ihm."
End If

rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub
Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------
Dim lngVerId As Long

'Hat der Nutzer alle erforderlichen Daten eingegeben?

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtName) = "" Then
   MsgBox "Bitte geben Sie einen Namen ein!"
   txtName.SetFocus
   Exit Sub
End If

' Gibt es diesen Verlag schon?

If (txtName <> txtName.OldValue Or _
    IsNull(txtName.OldValue)) And _
   DCount("ver_id", "tblVerlag", "ver_name='" & txtName & "'") > 0 Then
   MsgBox ("Diesen Verlag gibt es schon!")
   Me.Undo   ' Abbrechen der begonnenen Transaktion (Datensatzmarkierer beobachten!!)
   txtName.SetFocus
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord
lngVerId = Me!ver_id

lstVerlage.Enabled = True
lstVerlage.Requery
lstVerlage.SetFocus

' Anzeige des gespeicherten Verlages

lstVerlage = lngVerId
Call lstVerlage_AfterUpdate

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdNeu_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

lstVerlage = Null
DoCmd.GoToRecord , , acNewRec
txtName.SetFocus

cmdLoeschen.Enabled = False
cmdNeu.Enabled = False
lstVerlage.Enabled = False

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmSachgebiete'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmSachgebiete"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdKopieren_Click()
'--------------------------------------------------------------
'Der Name des aktuellen Sachgebietes wird in das Textfeld mit dem
'neuen Sachgebiet bernommen. Damit spart man sich das Eintippen,
'wenn man einen Teilbaum umhngen will.

If errorhandling Then On Error GoTo fehlerbehandlung

txtNeuesUntersachgebiet = txtSachgebiet
txtNeuesUntersachgebiet.SetFocus

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdStart_Click()
'--------------------------------------------------------------
' ffnen des Startformulars

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.OpenForm "frmStart"

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdHilfe_Click()
Call HilfeAnzeigen("sachgebiete")
End Sub

Private Sub cmdLoeschen_Click()
'--------------------------------------------------------------
' Ein Sachgebiet lschen

Dim rs As DAO.Recordset
Dim strOberstesSachgebiet As String
Dim lngAntwort As Long
Dim strMsgtext As String

If errorhandling Then On Error GoTo fehlerbehandlung

' Das oberste Sachgebiet darf nicht gelscht werden!

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = obersachgebiet"
strOberstesSachgebiet = rs!SACHGEBIET
rs.Close
Set rs = Nothing

If Me!txtSachgebiet = strOberstesSachgebiet Then
 MsgBox "Das oberste Sachgebiet darf nicht gelscht werden!"
 Exit Sub
End If

' Gibt es noch Bcher, die zu dem zu lschenden Sachgebiet gehren?
Set rs = CurrentDb.OpenRecordset("tblBuch_Sach", dbOpenDynaset)
rs.FindFirst "sachgebiet='" & Me!SACHGEBIET & "'"
If rs.NoMatch Then
  rs.Close
  Set rs = Nothing
Else
  MsgBox "Dieses Sachgebiet kann nicht gelscht werden," & vbCrLf & _
         "weil es dazu noch Bcher gibt!"
  rs.Close
  Set rs = Nothing
  Exit Sub
End If

' Hat das zu lschende Sachgebiet noch Untersachgebiete?
' (Oder, mit anderen Worten: Ist es noch irgendwo Obersachgebiet?)

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "obersachgebiet='" & Me!txtSachgebiet & "'"
If rs.NoMatch Then
   strMsgtext = "Wollen Sie das Sachgebiet " & vbCrLf & Me!txtSachgebiet & vbCrLf & "wirklich lschen ?"
   lngAntwort = MsgBox(strMsgtext, vbYesNo + vbDefaultButton2)
   If lngAntwort = vbYes Then
      CurrentDb.Execute ("DELETE FROM tblSachgebiet WHERE sachgebiet='" & Me!txtSachgebiet & "'")
      Forms!frmSachgebiete.Requery
      Forms!frmSachgebiete!lstSachgebiete.Requery
      Forms!frmSachgebiete!frmSachgebiete_ufoUntersachgebiete.Requery
      rs.Close
      Set rs = Nothing

      ' Zurck zum obersten Sachgebiet
      Set rs = Me.Recordset.Clone
      rs.FindFirst "sachgebiet = '" & strOberstesSachgebiet & "'"
      If Not rs.EOF Then Me.Bookmark = rs.Bookmark
      rs.Close
      Set rs = Nothing
      
   Else
      rs.Close
      Set rs = Nothing
      Exit Sub
   End If
Else
   rs.Close
   Set rs = Nothing
   MsgBox "Dieses Sachgebiet kann nicht gelscht werden," & vbCrLf & _
          "weil es noch Untersachgebiete hat!"
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSpeichern_Click()
'--------------------------------------------------------------
' Hinzufgen eines neuen Untersachgebietes

Dim rs As DAO.Recordset
Dim strAktuellesSachgebiet As String
Dim lngRecordNumber As Long
Dim lngAntwort As Long

If errorhandling Then On Error GoTo fehlerbehandlung

'Hat der Nutzer alle erforderlichen Daten eingegeben?

If Nz(txtNeuesUntersachgebiet) = "" Then
   MsgBox "Bitte geben Sie ein neues Untersachgebiet ein!"
   txtNeuesUntersachgebiet.SetFocus
   Exit Sub
End If

If txtNeuesUntersachgebiet = txtSachgebiet Then
   MsgBox "Ein Sachgebiet kann nicht sich selbst untergeordnet werden!"
   txtNeuesUntersachgebiet = ""
   txtNeuesUntersachgebiet.SetFocus
   Exit Sub
End If

'Sicherheitsabfrage

lngAntwort = MsgBox("Wollen Sie wirklich dem Sachgebiet" & vbCrLf & _
                 "   " & txtSachgebiet & vbCrLf & "das neue Untersachgebiet" & _
                 vbCrLf & "   " & txtNeuesUntersachgebiet & vbCrLf & "hinzufgen?", _
                 vbYesNo + vbDefaultButton2)
If lngAntwort = vbNo Then Exit Sub

' Am Ende der Prozedur muss ein requery aufgerufen werden.
' Daraufhin wird aber der erste Datensatz aus der Tabelle tblSachgebiet angezeigt.
' Damit nach dem requery aber wieder der jetzige aktuelle Datensatz angezeigt wird,
' merke ich mir diesen Datensatz, um nach dem requery hierher zurckkehren zu knnen!

strAktuellesSachgebiet = Me!txtSachgebiet

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet='" & Me!txtSachgebiet & "'"

' Jetzt wird nach dem hinzuzufgenden Sachgebiet gesucht.

rs.MoveFirst
rs.FindFirst "sachgebiet='" & txtNeuesUntersachgebiet & "'"

' Wird es nicht gefunden, wird es hinzugefgt und dem aktuellen Sachgebiet untergeordnet.
' Wird es gefunden, so wird es dem aktuellen Sachgebiet untergeordnet.
' Achtung: Damit wird der ganze Teilbaum unterhalb des hinzuzufgenden Sachgebietes "umgehngt"!

If rs.NoMatch Then
  rs.AddNew
  rs!SACHGEBIET = Me!txtNeuesUntersachgebiet
  rs!OBERSACHGEBIET = Me!txtSachgebiet
  rs.Update
  rs.Close
  Set rs = Nothing
Else
  rs.Edit   ' Freigabe fr die Bearbeitung
  rs!OBERSACHGEBIET = Me!txtSachgebiet   ' Bearbeitung
  rs.Update   ' Speichern des neuen Wertes
  rs.Close    ' Ende der Bearbeitung
  Set rs = Nothing  ' Lschen des Recordsets
End If

Forms!frmSachgebiete.Requery
Forms!frmSachgebiete!lstSachgebiete.Requery
Forms!frmSachgebiete!frmSachgebiete_ufoUntersachgebiete.Requery

' Zurck zum anfnglich angezeigten Sachgebiet

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = '" & strAktuellesSachgebiet & "'"
lngRecordNumber = rs.AbsolutePosition + 1
' AbsolutePosition liefert Null fr den ersten Datensatz - darum + 1 !
DoCmd.GoToRecord acDataForm, "frmSachgebiete", acGoTo, lngRecordNumber

' Es geht auch so:
'-------------------
'Set rst = Me.Recordset.Clone
'rst.FindFirst "sachgebiet = '" & aktuelles_sachgebiet & "'"
'If Not rst.EOF Then Me.Bookmark = rst.Bookmark
'rst.Close
'-------------------
' ABER: Das funktioniert NICHT MEHR nach der Aufteilung der Datei
'       in Front- und Backend, d.h. Bookmark funktioniert nicht fr
'       eingebundene Tabellen.

Me!txtNeuesUntersachgebiet = ""

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdObersachgebiet_Click()
'--------------------------------------------------------------
' Mache das Obersachgebiet des aktuellen Sachgebietes zum aktuellen Sachgebiet
' (Oder, mit anderen Worten: Gehe im Sachgebietsbaum einen Schritt zurck)

Dim rs As DAO.Recordset

If errorhandling Then On Error GoTo fehlerbehandlung

Set rs = Me.Recordset.Clone
rs.FindFirst "sachgebiet='" & Me!OBERSACHGEBIET & "'"
If Not rs.EOF Then Me.Bookmark = rs.Bookmark
rs.Close
Set rs = Nothing

txtSachgebiet.SetFocus

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdOberstesSachgebiet_Click()
'--------------------------------------------------------------
' Zurck zum obersten Sachgebiet

Dim rs As DAO.Recordset
Dim strOberstesSachgebiet As String

If errorhandling Then On Error GoTo fehlerbehandlung

' Finde das oberste Sachgebiet, d.h. das Sachgebiet, fr das
' sachgebiet = obersachgebiet ist

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = obersachgebiet"
strOberstesSachgebiet = rs!SACHGEBIET
rs.Close
Set rs = Nothing

' Mache das oberste Sachgebiet zum aktuellen Sachgebiet

Set rs = Me.Recordset.Clone
rs.FindFirst "sachgebiet = '" & strOberstesSachgebiet & "'"
If Not rs.EOF Then Me.Bookmark = rs.Bookmark
rs.Close
Set rs = Nothing

txtSachgebiet.SetFocus

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdSchliessen_Click()
'--------------------------------------------------------------

If errorhandling Then On Error GoTo fehlerbehandlung

DoCmd.Close

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub cmdAendern_Click()
'--------------------------------------------------------------
' Den Namen eines vorhandenen Sachgebietes ndern

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(txtSachgebiet) = "" Then
   MsgBox "Bitte geben Sie ein Sachgebiet ein!"
   txtSachgebiet.Value = txtSachgebiet.OldValue
   txtSachgebiet.SetFocus
   Exit Sub
End If

If DCount("buchsach_id", "tblBuch_Sach", "sachgebiet='" & txtSachgebiet.OldValue & "'") > 0 Then
   MsgBox "Der Name dieses Sachgebietes kann nicht mehr gendert werden," & vbCrLf & _
          "weil es bereits Bchern zugeordnet wurde!"
   txtSachgebiet.Value = txtSachgebiet.OldValue
   Me.Undo
   Exit Sub
End If

DoCmd.RunCommand acCmdSaveRecord
lstSachgebiete.Requery

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub Form_Open(Cancel As Integer)
'--------------------------------------------------------------
'Zeige nach dem ffnen das oberste Sachgebiet an!

Dim rs As DAO.Recordset
Dim strOberstesSachgebiet As String

If errorhandling Then On Error GoTo fehlerbehandlung

Me.Cycle = 1

'Finde das oberste Sachgebiet

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = obersachgebiet"

If rs.NoMatch Then
   MsgBox "Es gibt kein Sachgebiet, bei dem sachgebiet=obersachgebiet ist" & vbCrLf & _
          "(oberstes Sachgebiet). Bitte legen Sie ein solches Sachgebiet an," & vbCrLf & _
          "sonst wird dieses Formular nicht funktionieren!"
   rs.Close
   Set rs = Nothing
   Exit Sub
End If

strOberstesSachgebiet = rs!SACHGEBIET
rs.Close
Set rs = Nothing

' ... oder auch so:
' oberstes_sachgebiet = DLookup("sachgebiet", "tblSachgebiet", "sachgebiet=obersachgebiet")
' Achtung: oberstes_sachgebiet muss dann vom Typ Variant sein!

Set rs = Me.Recordset.Clone
rs.FindFirst "sachgebiet = '" & strOberstesSachgebiet & "'"
If Not rs.EOF Then Me.Bookmark = rs.Bookmark
rs.Close
Set rs = Nothing

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub lstSachgebiete_AfterUpdate()
'--------------------------------------------------------------
'Die Daten des in der Liste angeclickten Datensatzes anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

If Not IsNull(lstSachgebiete) Then Me.Recordset.FindFirst "sachgebiet='" & Me!lstSachgebiete & "'"

txtSachgebiet.SetFocus

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtNeuesUntersachgebiet_GotFocus()
cmdSpeichern.Enabled = True
cmdAendern.Enabled = False
cmdLoeschen.Enabled = False
End Sub

Private Sub txtSachgebiet_BeforeUpdate(Cancel As Integer)
' Ist das Eingabefeld leer?
' Cancel = True bewirkt, dass das Update NICHT ausgefhrt wird,
' was in diesem Fall bedeutet, dass der Inhalt des Eingabefeldes
' nicht gelscht wird!
' Das Drcken der Esc-Taste bewirkt, dass ein gelschter Wert
' wieder hergestellt wird.
' Summa summarun wird alo verhindert, dass der Datensatz mit
' einem leeren Eingabefeld gespeichert wird!

If errorhandling Then On Error GoTo fehlerbehandlung

If Nz(Me!txtSachgebiet) = "" Then
   MsgBox "Bitte geben Sie einen Sachgebietsnamen ein oder drcken Sie die Esc-Taste!"
   Cancel = True
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

Private Sub txtSachgebiet_GotFocus()

If errorhandling Then On Error GoTo fehlerbehandlung

cmdSpeichern.Enabled = False
cmdAendern.Enabled = True
cmdLoeschen.Enabled = True

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmSachgebiete_ufoUntersachgebiete'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmSachgebiete_ufoUntersachgebiete"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtSachgebiet_Click()
'--------------------------------------------------------------
'Mache das angeclickte Untersachgebiet zum aktuellen Sachgebiet

Dim lngRecordNumber As Long
Dim rs As DAO.Recordset

If errorhandling Then On Error GoTo fehlerbehandlung

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = '" & Me!SACHGEBIET & "'"
lngRecordNumber = rs.AbsolutePosition + 1
' AbsolutePosition liefert Null fr den ersten Datensatz !
' Darum + 1 !
' MsgBox Str(lngRecordNumber)

DoCmd.GoToRecord acDataForm, "frmSachgebiete", acGoTo, lngRecordNumber

rs.Close
Set rs = Nothing
Forms!frmSachgebiete!txtSachgebiet.SetFocus

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub


========================================================
Code of the form 'frmZuweisung_ufoUntersachgebiete'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmZuweisung_ufoUntersachgebiete"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub txtSachgebiet_Click()
'--------------------------------------------------------------
'Mache das angeclickte Untersachgebiet zum aktuellen Sachgebiet

If errorhandling Then On Error GoTo fehlerbehandlung

Dim lngRecordNumber As Long
Dim rs As DAO.Recordset

Set rs = CurrentDb.OpenRecordset("tblSachgebiet", dbOpenDynaset)
rs.FindFirst "sachgebiet = '" & Me!txtSachgebiet & "'"
lngRecordNumber = rs.AbsolutePosition + 1
' AbsolutePosition liefert Null fr den ersten Datensatz !
' Darum + 1 !
' MsgBox Str(lngRecordNumber)

DoCmd.GoToRecord acDataForm, "frmZuweisung", acGoTo, lngRecordNumber

rs.Close
Set rs = Nothing
Parent!txtSachgebiet.SetFocus

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub

========================================================
Code of the form 'frmExport'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmExport"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdStart_Click()
' Writes the VBA code of all forms and modules to an export file "Code_Export.txt"

Dim objObject As Object
Dim mdlModule As Module
Dim modModules As Modules
Dim lngModuleNr As Long
Dim strExportFile As String

strExportFile = Application.CurrentProject.Path & "\Code_Export.txt"

' Does the file 'Export_Code.txt' already exist?

If Dir(strExportFile) <> "" Then
   
   ' If yes - is it not empty?
   
   If FileLen(strExportFile) > 0 Then
      
      MsgBox "The file 'Export_Code.txt' exists already" & vbCrLf & _
             "and is not empty!", vbExclamation, "WARNING"
      Exit Sub
   
   End If
   
End If

' If it does not exist or if it exists and is empty:
' Write the title line

Open strExportFile For Output As #1
Print #1, "++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
Print #1, "++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
Print #1, "VBA Code of the data base '" & Application.CurrentProject.Name & "'"
Print #1, Date
Print #1, "++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
Print #1, "++++++++++++++++++++++++++++++++++++++++++++++++++++++++"

Close #1

Set modModules = Application.Modules

' Loop over all forms
' ===================

For Each objObject In CurrentProject.AllForms
   
   ' Loop over all modules
   
   For lngModuleNr = 0 To modModules.Count - 1
   
      'MsgBox modModules(lngModuleNr).Name & " / " & objObject.Name
      
      ' Does a module exist for the form objObject?
      
      If modModules(lngModuleNr).Name = "Form_" & objObject.Name Then
      
            ' Write the module code to a temporary file 'temptemp.txt'
            
            DoCmd.OutputTo acOutputModule, _
                           modModules(lngModuleNr).Name, _
                           acFormatTXT, _
                           Application.CurrentProject.Path & "\temptemp.txt"

            ' Append the temporary file to the export file 'Code_Export.txt'
            
            WriteFile strExportFile, _
                      ReadFile(strExportFile) & vbCrLf & _
                      "========================================================" & vbCrLf & _
                      "Code of the form '" & objObject.Name & "'" & vbCrLf & _
                      "========================================================" & vbCrLf & _
                      ReadFile(Application.CurrentProject.Path & "\temptemp.txt")

      
      End If
      
   Next lngModuleNr
      
Next objObject

' Loop over all modules
' =====================

For Each objObject In CurrentProject.AllModules

   ' Write the module code to a temporary file 'temptemp.txt'

   DoCmd.OutputTo acOutputModule, _
                  objObject.Name, _
                  acFormatTXT, _
                  Application.CurrentProject.Path & "\temptemp.txt"
   
   ' Append the temporary file to the export file 'Code_Export.txt'
            
   WriteFile strExportFile, _
             ReadFile(strExportFile) & vbCrLf & _
             "**********************************************************************" & vbCrLf & _
             "**********************************************************************" & vbCrLf & _
             "Code of the module '" & objObject.Name & "'" & vbCrLf & _
             "**********************************************************************" & vbCrLf & _
             "**********************************************************************" & vbCrLf & _
             ReadFile(Application.CurrentProject.Path & "\temptemp.txt")
   
Next objObject

Kill Application.CurrentProject.Path & "\temptemp.txt"

MsgBox "Ready!" & vbCrLf & lngModuleNr - 1 & " form(s) and " & vbCrLf & _
                           CurrentProject.AllModules.Count & " module(s) exported to 'Export_Code.txt'!"

End Sub

Function ReadFile(ByRef Path As String) As String
' Quelle: http://vb-tec.de/readfile.htm

Dim FileNr As Long
  
FileNr = FreeFile

Open Path For Binary As #FileNr
ReadFile = Space$(LOF(FileNr))
Get #FileNr, , ReadFile
Close #FileNr

End Function

Sub WriteFile(ByRef Path As String, ByRef Text As String)
' Quelle: http://vb-tec.de/speicher.htm

Dim FileNr As Long
  
FileNr = FreeFile
Open Path For Output As #FileNr
Print #FileNr, Text;
Close #FileNr

End Sub

========================================================
Code of the form 'frmErsterStart'
========================================================
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Form_frmErsterStart"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub cmdSchliessen_Click()

Select Case chkAnzeigen
Case 0   ' Formular anzeigen
   
   CurrentDb.Execute "UPDATE tblDBINFO SET dbi_wert='ja' WHERE dbi_name='erster_start'"

Case -1   ' Formular NICHT anzeigen
   
   CurrentDb.Execute "UPDATE tblDBINFO SET dbi_wert='nein' WHERE dbi_name='erster_start'"

End Select

DoCmd.Close
End Sub

Private Sub Form_Open(Cancel As Integer)

If DLookup("dbi_wert", "tblDBINFO", "dbi_name='erster_start'") = "nein" Then
   Cancel = True
End If

End Sub

**********************************************************************
**********************************************************************
Code of the module 'Hilfsprozeduren'
**********************************************************************
**********************************************************************
Attribute VB_Name = "Hilfsprozeduren"
Option Compare Database
Option Explicit

Public Function eigene_MFL_laden()
' Der Wert der Konstanten "Accessversion" wird so gesetzt:
' In VBA: Extras / Eigenschaften von ...
' Dort unter "Argumente fr die bedingte Kompilierung"
' Will man dort mehrere Konstanten definieren,
' so mssen sie durch Doppelpunkte voneinander getrennt werden!

#If Accessversion > 2003 Then
   Application.LoadCustomUI "Eigene_MFL", _
                            DLookup("mfl_code", "tblMFL", "mfl_name='eigene_MFL'")
#End If
End Function

#If Accessversion > 2003 Then

Sub OnButtonClick(control As IRibbonControl)
Select Case control.id

   Case "startformular"
      DoCmd.OpenForm "frmStart"

   Case "ausleihe"
      DoCmd.OpenForm "frmAusleihe"
   Case "personen"
      DoCmd.OpenForm "frmRueckgabe"

   Case "erfassen"
      DoCmd.OpenForm "frmBuecher"
   Case "suchen"
      DoCmd.OpenForm "frmBuechersuche"

   Case "autoren"
      DoCmd.OpenForm "frmAutoren"
   Case "sachgebiete"
      DoCmd.OpenForm "frmSachgebiete"
   Case "verlage"
      DoCmd.OpenForm "frmVerlage"
   Case "orte"
      DoCmd.OpenForm "frmOrte"
   Case "lager"
      DoCmd.OpenForm "frmLager"
   Case Else
      MsgBox "OnButtonClick: Unbekannter Formularname!"

End Select
End Sub
#End If

Public Function errorhandling() As Boolean
' Wenn Sie errorhandling = True setzen, knnen Sie damit
' eine selbst definierte Fehlermeldung einschalten.
' Das hat den Vorteil, dass der Nutzer keine Laufzeitfehler
' zu sehen bekommt, die oft verwirrend und unverstndlich sind.
' Wie diese selbst geschriebene Fehlerbehandlung funktioniert,
' knnen Sie sich in einer beliebigen Prozedur ansehen.

' Fast alle Prozeduren enthalten nmlich am Ende diesen Code:

'Exit Sub
'fehlerbehandlung:
'   MsgBox "Fehler " & Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & _
'          "FR ENTWICKLER: " & vbCrLf & _
'          "------------------" & vbCrLf & _
'          "Wenn Sie unter Module / Hilfsprozeduren / errorhandling eingeben:" & vbCrLf & _
'          "errorhandling = False" & vbCrLf & _
'          "knnen Sie sich die System-Fehlermeldungen anzeigen lassen" & vbCrLf & _
'          "und zum Debugging wechseln!", vbCritical

errorhandling = False
End Function

Public Function FormIsOpen(strFormname As String) As Boolean
Dim frm As Form

FormIsOpen = False
For Each frm In Forms
   If frm.Name = strFormname Then FormIsOpen = True
Next frm

End Function

Public Function sqldatum(datNormaldatum As Date) As String

' Umwandlung eines Datums in das Format, das in SQL-Anweisungen bentigt wird,
' also z.B. #03/25/2008# statt 25.3.2008

sqldatum = "#" & Month(datNormaldatum) & "/" & Day(datNormaldatum) & "/" & Year(datNormaldatum) & "#"
End Function

Public Sub HilfeAnzeigen(strObjektname As String)
'--------------------------------------------------------------
'Hilfe-Datei anzeigen

If errorhandling Then On Error GoTo fehlerbehandlung

Dim strDateiname As String
Dim fso As Object

strDateiname = Application.CurrentProject.Path & "\hilfe-" & strObjektname

' In Access 2003 knnen Textboxen keine .rtf-Daten darstellen.
' Darum dort nur .txt-Dateien als Hilfedateien!

' Der Wert der Konstanten "Accessversion" wird so gesetzt:
' In VBA: Extras / Eigenschaften von ...
' Dort unter "Argumente fr die bedingte Kompilierung"
' Will man dort mehrere Konstanten definieren,
' so mssen sie durch Doppelpunkte voneinander getrennt werden!

#If Accessversion > 2003 Then
   strDateiname = strDateiname & ".rtf"
#Else
   strDateiname = strDateiname & ".txt"
#End If

Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strDateiname) Then
   DoCmd.OpenForm "frmHilfe", , , , , , strDateiname
Else
   MsgBox "Fr dieses Formular existiert leider keine Hilfe-Information."
End If

Exit Sub
fehlerbehandlung:
   MsgBox "Fehler " & Err.Number & ": " & Err.Description, vbCritical

End Sub
