Nicht in der Liste Öffnen Sie mit einem Doppelklick die Kombinationsfelder Ihrer Anwendung.
Autor:   Microsys Kramer	Bewertung:	Views:  17.101
www.access-paradies.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Dieses Demoformular zeigt Ihnen eine weitere Möglichkeit der Funktion "Bei Nicht in Liste".
Normalerweise können Sie nur vorhandene Listeneinträge bei der o.g. Funktion auswählen.
Wenn nun die eingegebene Bezeichnung nicht in der Liste vorhanden ist, können Sie in dieser Demo den Wert auch in die Liste hinzufügen lassen, jedoch müssen Sie nicht! Der eingegebene Wert wird auch akzeptiert, wenn dieser kein Inhalt der Auswahlliste ist.

Wenn Sie [Strg] + [Entf] drücken, können Sie den ausgewählten Eintrag aus der Liste entfernen.

Durch Drücken von [Strg] + [Return] können Sie den ausgewählten Eintrag sogar ändern.

Erstellen Sie ein neues Formular und fügen Sie folgende Steuerelemente ein:

• Bezeichnungsfeld: Beschriftung "Bezeichnung"
• Kombinationsfeld: Name Bezeichnung

Option Compare Database
Option Explicit
 
Private Sub Bezeichnung_AfterUpdate()
  On Error GoTo Err_Bezeichnung_AfterUpdate
  Dim db As Database, DSGruppe1 As Recordset
 
  If ((IsNull(Me![Bezeichnung])) Or _
    (Me![Bezeichnung] = "")) Then Exit Sub
 
  If Not IsNull(DLookup("[Eintrag]", "tbl_Einträge", _
    "[Eintrag] = '" & Me![Bezeichnung] & "'")) Then 
    Exit Sub
  End If
 
  If vbYes = MsgBox("Möchten Sie " & Chr(34) & _
    Me![Bezeichnung] & Chr(34) & " zur Liste hinzufügen?", _
    vbYesNo + vbQuestion, "Microsys Kramer - Demo") Then
    Set db = CurrentDb
    Set DSGruppe1 = db.OpenRecordset("tbl_Einträge")
    DSGruppe1.AddNew
    DSGruppe1!Eintrag = Me![Bezeichnung]
    DSGruppe1.Update
    DSGruppe1.Close
    Me![Bezeichnung].Requery
  End If
 
Exit_Bezeichnung_AfterUpdate:
  Exit Sub
 
Err_Bezeichnung_AfterUpdate:
  MsgBox Err.Description
  Resume Exit_Bezeichnung_AfterUpdate
End Sub
 
Private Sub Bezeichnung_KeyDown(KeyCode As Integer, _
  Shift As Integer)
  ' On Error GoTo Err_Bezeichnung_KeyDown
 
  Dim db As Database, DSGruppe1 As Recordset
  Dim Kriterien As String
  Dim Mldg, Titel, Voreinstellung
  Dim H_Bezeichnung As String
 
  Mldg = "Geben Sie eine Bezeichnung ein!"
  Titel = "Microsys Kramer - Demo"
  If ((KeyCode = 46) And (Shift = 2)) Then
    If ((IsNull(Me![Bezeichnung])) Or _
      (Me![Bezeichnung] = "")) Then Exit Sub
 
    If IsNull(DLookup("[Eintrag]", "tbl_Einträge", _
      "[Eintrag] = '" & Me![Bezeichnung] & "'")) Then
      Exit Sub
    End If
 
    If vbYes = MsgBox("Möchten Sie " & Chr(34) & _
      Me![Bezeichnung] & Chr(34) & _
      " aus Liste löschen?", vbYesNo + vbQuestion, _
      "Microsys Kramer - Demo") Then
 
      DoCmd.Hourglass True
      Set db = CurrentDb
      Set DSGruppe1 = db.OpenRecordset("tbl_Einträge", _
        DB_OPEN_DYNASET)
      Kriterien = "[Eintrag] = '" & Me![Bezeichnung] & "'"
      DSGruppe1.FindFirst Kriterien
      If Not DSGruppe1.NoMatch Then
        DSGruppe1.Delete
      End If
      Me![Bezeichnung].Requery
      DSGruppe1.Close
      Me![Bezeichnung] = Null
      DoCmd.Hourglass False
    End If
  End If
 
  If ((KeyCode = 13) And (Shift = 2)) Then
    If ((IsNull(Me![Bezeichnung])) Or _
      (Me![Bezeichnung] = "")) Then Exit Sub
 
    H_Bezeichnung = InputBox(Mldg, Titel, Bezeichnung)
    If (H_Bezeichnung = "") Or _
      (IsNull(H_Bezeichnung)) Then Exit Sub
    Set db = CurrentDb
    Set DSGruppe1 = db.OpenRecordset("tbl_Einträge", _
      DB_OPEN_DYNASET)
    DSGruppe1.FindFirst "Eintrag = '" & _
      Me![Bezeichnung] & "'"
    If Not DSGruppe1.NoMatch Then
      DSGruppe1.Edit
      DSGruppe1!Eintrag = H_Bezeichnung
      DSGruppe1.Update
    End If
    DSGruppe1.Close
    Me![Bezeichnung] = H_Bezeichnung
    Me![Bezeichnung].Requery
  End If
 
Exit_Bezeichnung_KeyDown:
  Exit Sub
 
Err_Bezeichnung_KeyDown:
  MsgBox Err.Description
  Resume Exit_Bezeichnung_KeyDown
End Sub
 
Private Sub Bezeichnung_NotInList(NewData As String, _
  Response As Integer)
  On Error GoTo Err_Bezeichnung_NotInList
 
  Dim db As Database, DSGruppe1 As Recordset
 
  If vbYes = MsgBox("Möchten Sie " & Chr(34) & _
    NewData & Chr(34) & " zur Liste hinzufügen?", _
    vbYesNo + vbQuestion, "Microsys Kramer - Demo") Then
 
    Set db = CurrentDb
    Set DSGruppe1 = db.OpenRecordset("tbl_Einträge")
    DSGruppe1.AddNew
    DSGruppe1!Eintrag = NewData
    DSGruppe1.Update
    DSGruppe1.Close
    Response = acDataErrAdded
  Else
    Response = acDataErrDisplay
  End If
 
Exit_Bezeichnung_NotInList:
  Exit Sub
 
Err_Bezeichnung_NotInList:
  MsgBox Err.Description
  Resume Exit_Bezeichnung_NotInList
End Sub
 
Private Sub OK_Click()
  On Error GoTo Err_OK_Click
 
  DoCmd.Close
 
Exit_OK_Click:
  Exit Sub
 
Err_OK_Click:
  MsgBox Err.Description
  Resume Exit_OK_Click
End Sub

Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.