vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevDataGrid - Gönnen Sie Ihrem SQL-Kommando diesen krönenden Abschluß!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Access   |   VB-Versionen: VBA02.08.01
Nicht in der Liste

Öffnen Sie mit einem Doppelklick die Kombinationsfelder Ihrer Anwendung.

Autor:   Microsys KramerBewertung:     [ Jetzt bewerten ]Views:  14.967 
www.access-paradies.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 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

Dieser Tipp wurde bereits 14.967 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle 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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel