VERSION 5.00 Begin VB.Form frmGericht BorderStyle = 3 'Fester Dialog Caption = "Gericht" ClientHeight = 5130 ClientLeft = 45 ClientTop = 435 ClientWidth = 8055 LinkTopic = "Form2" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 5130 ScaleWidth = 8055 ShowInTaskbar = 0 'False StartUpPosition = 2 'Bildschirmmitte Begin VB.CheckBox Check1 Caption = "Check1" Height = 255 Left = 1320 TabIndex = 17 Top = 4320 Width = 1815 End Begin VB.CommandButton cmdAbbrechen Caption = "Abbrechen" Height = 495 Left = 5880 TabIndex = 5 Top = 4440 Width = 1305 End Begin VB.CommandButton cmdSpeichern Caption = "Speichern" Height = 495 Left = 4200 TabIndex = 4 Top = 4440 Width = 1305 End Begin VB.Frame Frame1 Height = 3975 Left = 1200 TabIndex = 7 Top = 240 Width = 5895 Begin VB.ComboBox ComboStationsDrucker Height = 315 Left = 2160 TabIndex = 16 Text = "ComboStationsDrucker" Top = 3240 Width = 2295 End Begin VB.ComboBox ComboBonDrucker Height = 315 Left = 2160 TabIndex = 15 Text = "ComboBonDrucker" Top = 2760 Width = 2175 End Begin VB.TextBox txtGericht Height = 285 Left = 1920 TabIndex = 1 Top = 960 Width = 2295 End Begin VB.TextBox txtEPREIS BeginProperty DataFormat Type = 0 Format = "#.##0,00 ""€""" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1031 SubFormatType = 0 EndProperty Height = 285 Left = 1920 TabIndex = 2 Top = 1440 Width = 2655 End Begin VB.TextBox txtMwSt BeginProperty DataFormat Type = 1 Format = "0,00%" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1031 SubFormatType = 5 EndProperty Height = 315 Left = 2040 TabIndex = 3 Top = 1920 Width = 2325 End Begin VB.TextBox txtWarengruppe Appearance = 0 '2D BackColor = &H80000011& Enabled = 0 'False BeginProperty Font Name = "Tahoma" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 315 Left = 1920 TabIndex = 6 Top = 240 Width = 2745 End Begin VB.TextBox txtPLU Height = 315 Left = 1920 TabIndex = 0 Top = 600 Width = 2535 End Begin VB.Label lblStationsDrucker Caption = "Stationsdrucker" BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 600 TabIndex = 14 Top = 3240 Width = 1455 End Begin VB.Label lblBonDrucker Caption = "Bondrucker" BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 720 TabIndex = 13 Top = 2880 Width = 1095 End Begin VB.Label lblFieldLabel Caption = "Gericht:" BeginProperty Font Name = "Tahoma" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Index = 2 Left = 840 TabIndex = 12 Top = 1200 Width = 675 End Begin VB.Label lblFieldLabel Caption = "Verkaufpreis:" BeginProperty Font Name = "Tahoma" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Index = 3 Left = 600 TabIndex = 11 Top = 1560 Width = 1155 End Begin VB.Label lblFieldLabel Caption = "MwSt:" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Index = 4 Left = 840 TabIndex = 10 Top = 1920 Width = 525 End Begin VB.Label lblFieldLabel Caption = "Warengruppe:" BeginProperty Font Name = "Tahoma" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Index = 0 Left = 360 TabIndex = 9 Top = 360 Width = 1245 End Begin VB.Label lblFieldLabel Caption = "PLU:" BeginProperty Font Name = "Tahoma" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 240 Index = 1 Left = 960 TabIndex = 8 Top = 720 Width = 390 End End End Attribute VB_Name = "frmGericht" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Dim VarGerichrtBearbeiten As Boolean '================== FORMULAR EREIGNISSE =================== '============================================================ Private Sub Form_Load() AbstandRand = MDIHauptmenu.ScaleWidth / 60 Me.Width = 0.5 * MDIHauptmenu.ScaleWidth Me.Height = 0.5 * MDIHauptmenu.ScaleHeight Me.Left = MDIHauptmenu.ScaleWidth / 2 - Me.Width / 2 Me.Top = MDIHauptmenu.ScaleHeight / 2 - Me.Height / 2 Me.Frame1.Top = AbstandRand Me.Frame1.Left = AbstandRand Me.Frame1.Width = Me.ScaleWidth - 2 * AbstandRand Me.Frame1.Height = Me.ScaleHeight - 4 * AbstandRand Me.lblFieldLabel.Item(0).Height = Me.Frame1.Height / 12 Me.lblFieldLabel.Item(0).Width = 0.25 * Me.Frame1.Width Me.lblFieldLabel.Item(0).Left = Me.Frame1.Width / 2 - (3 * Me.lblFieldLabel.Item(0).Width + AbstandRand) / 2 Me.lblFieldLabel.Item(0).Top = AbstandRand AbstandInnen = Me.Frame1.Height / 20 For I = 1 To Me.lblFieldLabel.Count - 1 Me.lblFieldLabel.Item(I).Width = Me.lblFieldLabel.Item(I - 1).Width Me.lblFieldLabel.Item(I).Left = Me.lblFieldLabel.Item(I - 1).Left Me.lblFieldLabel.Item(I).Height = Me.lblFieldLabel.Item(I - 1).Height Me.lblFieldLabel.Item(I).Top = Me.lblFieldLabel.Item(I - 1).Top + Me.lblFieldLabel.Item(I - 1).Height + 0.5 * AbstandInnen Next I Me.txtWarengruppe.Top = Me.lblFieldLabel.Item(0).Top Me.txtWarengruppe.Left = Me.lblFieldLabel.Item(0).Left + Me.lblFieldLabel.Item(0).Width + AbstandRand Me.txtWarengruppe.Height = Me.lblFieldLabel.Item(0).Height Me.txtWarengruppe.Width = 2 * Me.lblFieldLabel.Item(0).Width Me.txtPLU.Top = Me.lblFieldLabel.Item(1).Top Me.txtPLU.Left = Me.txtWarengruppe.Left Me.txtPLU.Width = Me.txtWarengruppe.Width Me.txtPLU.Height = Me.txtWarengruppe.Height Me.txtGericht.Top = Me.lblFieldLabel.Item(2).Top Me.txtGericht.Left = Me.txtWarengruppe.Left Me.txtGericht.Height = Me.txtWarengruppe.Height Me.txtGericht.Width = Me.txtWarengruppe.Width Me.txtEPREIS.Top = Me.lblFieldLabel.Item(3).Top Me.txtEPREIS.Left = Me.txtWarengruppe.Left Me.txtEPREIS.Height = Me.txtWarengruppe.Height Me.txtEPREIS.Width = Me.txtWarengruppe.Width Me.txtMwSt.Top = Me.lblFieldLabel.Item(4).Top Me.txtMwSt.Left = Me.txtWarengruppe.Left Me.txtMwSt.Height = Me.txtWarengruppe.Height Me.txtMwSt.Width = Me.txtWarengruppe.Width Me.cmdAbbrechen.Top = Me.Frame1.Top + Frame1.Height + 0.5 * AbstandRand Me.cmdAbbrechen.Left = Me.Frame1.Left + Frame1.Width - Me.cmdAbbrechen.Width Me.cmdSpeichern.Top = Me.cmdAbbrechen.Top Me.cmdSpeichern.Left = Me.cmdAbbrechen.Left - Me.cmdAbbrechen.Width - AbstandRand Me.cmdSpeichern.Width = Me.cmdAbbrechen.Width Me.cmdSpeichern.Height = Me.cmdAbbrechen.Height Me.Check1.Caption = "Extras für das Gericht aktivieren" Me.Check1.Width = Me.cmdSpeichern.Left - Me.Frame1.Left - AbstandRand Me.Check1.Left = Me.Frame1.Left Me.Check1.Top = Me.cmdSpeichern.Top Me.lblBonDrucker.Left = Me.lblFieldLabel.Item(0).Left Me.lblBonDrucker.Width = Me.lblFieldLabel.Item(0).Width Me.lblBonDrucker.Top = Me.txtMwSt.Top + Me.txtMwSt.Height + AbstandRand Me.lblBonDrucker.Height = Me.ComboBonDrucker.Height Me.ComboBonDrucker.Clear Me.ComboBonDrucker.AddItem "Thekendrucker" Me.ComboBonDrucker.AddItem "Küchendrucker" Me.ComboBonDrucker.Text = Me.ComboBonDrucker.List(0) Me.ComboBonDrucker.Top = Me.lblBonDrucker.Top Me.ComboBonDrucker.Left = Me.lblBonDrucker.Left + Me.lblBonDrucker.Width + AbstandRand Me.ComboBonDrucker.Width = 1.5 * Me.lblBonDrucker.Width Me.lblStationsDrucker.Left = Me.lblBonDrucker.Left Me.lblStationsDrucker.Top = Me.lblBonDrucker.Top + Me.lblBonDrucker.Height + 0.5 * AbstandRand Me.lblStationsDrucker.Height = Me.lblBonDrucker.Height Me.lblStationsDrucker.Width = Me.lblBonDrucker.Width ComboStationsDrucker.Clear Call Me.StationenAbfragen Me.ComboStationsDrucker.Top = Me.lblStationsDrucker.Top Me.ComboStationsDrucker.Left = Me.ComboBonDrucker.Left Me.ComboStationsDrucker.Width = 1.5 * Me.lblStationsDrucker.Width End Sub '================== COMMANDBUTTON EREIGNISSE =================== '============================================================ Private Sub CmdSpeichern_Click() If frmGericht.txtPLU.Text = "" Then MsgBox "Es muss eine Artikelnummer eingegeben werden" Exit Sub ElseIf frmGericht.txtGericht.Text = "" Then MsgBox "Es muss ein Gericht eingegeben werden" Exit Sub ElseIf frmGericht.txtEPREIS.Text = "" Then MsgBox "Es muss der Verkaufpreis eingegeben werden" Exit Sub ElseIf frmGericht.txtMwSt.Text = "" Then MsgBox "Es muss der Mehrwertsteuersatz eingegeben werden" Exit Sub End If If VarGerichrtBearbeiten = True Then If Me.ArtikelBearbeitenSpeichern = True Then Call frmSpeisekarte.Artikelgruppe(frmGericht.txtWarengruppe.Text) 'Liste Aktalisieren Unload frmGericht Else Exit Sub End If Else If Me.ArtikelNeuSpeichern = True Then Call frmSpeisekarte.Artikelgruppe(frmGericht.txtWarengruppe.Text) 'Liste Aktalisieren Unload frmGericht Else Exit Sub End If End If End Sub Private Sub cmdAbbrechen_Click() Unload frmGericht End Sub '================== PROZEDUREN EREIGNISSE =================== '============================================================ '---------Tabelle Artikelgruppe Bearbeiten------------- Sub ArtikelBearbeitenZeigen() VarGerichrtBearbeiten = True Set objConn = New ADODB.Connection Set rsBearbeitenZeigen = New ADODB.Recordset Dim strPath As String On Error GoTo err_Handler strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" Set objConn = New ADODB.Connection Set rsOeffnen = New ADODB.Recordset With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & VarDatenbank .CursorLocation = adUseClient .Open End With With rsBearbeitenZeigen .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic '.Source = e Where Station='" & VarStation & "' and Tisch='" & VarTisch & "'" .Open "Select *FROM Artikelgruppe WHERE PLU ='" & frmSpeisekarte.ListViewArtikelgruppe.SelectedItem.Text & "'" '.Find ("PLU='" & frmSpeisekarte.ListViewArtikelgruppe.SelectedItem.Text & "'") End With Me.txtWarengruppe.Text = rsBearbeitenZeigen.Fields("WG").Value Me.txtPLU.Text = rsBearbeitenZeigen.Fields("PLU").Value Me.txtGericht.Text = rsBearbeitenZeigen.Fields("Gericht").Value Me.txtEPREIS.Text = rsBearbeitenZeigen.Fields("EPREIS").Value Me.txtMwSt.Text = rsBearbeitenZeigen.Fields("Mwst").Value Me.ComboStationsDrucker.Text = rsBearbeitenZeigen.Fields("Stationsdrucker").Value Me.ComboBonDrucker.Text = rsBearbeitenZeigen.Fields("Bondrucker").Value Me.Check1.Value = Abs(CInt(rsBearbeitenZeigen.Fields("Extra").Value)) Set rsBearbeitenZeigen = Nothing Set objConn = Nothing exit_Sub: On Error GoTo 0 Exit Sub err_Handler: MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" Resume exit_Sub Set rsBearbeitenZeigen = Nothing Set objConn = Nothing End Sub '---------Daten Speichern in Tabelle Artikelgruppe------------- Function ArtikelBearbeitenSpeichern() Dim objConn As ADODB.Connection Dim rsArtikel As ADODB.Recordset Dim rsPLU As ADODB.Recordset Set objConn = New ADODB.Connection Set rsArtikel = New ADODB.Recordset Set rsPLU = New ADODB.Recordset Dim strPath As String On Error GoTo err_Handler strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" Set objConn = New ADODB.Connection Set rsMain = New ADODB.Recordset With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & VarDatenbank .CursorLocation = adUseClient .Open End With With rsPLU .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic '.Source = e Where Station='" & VarStation & "' and Tisch='" & VarTisch & "'" .Open "Select *FROM Artikelgruppe WHERE PLU ='" & Me.txtPLU.Text & "'" '.Find ("PLU='" & frmSpeisekarte.ListViewArtikelgruppe.SelectedItem.Text & "'") End With With rsArtikel .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic '.Source = e Where Station='" & VarStation & "' and Tisch='" & VarTisch & "'" .Open "Select *FROM Artikelgruppe WHERE PLU ='" & frmSpeisekarte.ListViewArtikelgruppe.SelectedItem.Text & "'" '.Find ("PLU='" & frmSpeisekarte.ListViewArtikelgruppe.SelectedItem.Text & "'") End With If rsPLU.EOF = True Then 'Wenn kein Gericht vorhanden MsgBox "nicht gefunden" If MsgBox("PLU wurde geändert. Möchten Sie die Daten trotzdem Speichern", vbYesNo) = vbYes Then rsPLU.Delete rsArtikel.AddNew rsArtikel.Fields("WG").Value = Me.txtWarengruppe.Text rsArtikel.Fields("PLU").Value = Me.txtPLU.Text rsArtikel.Fields("Gericht").Value = Me.txtGericht.Text rsArtikel.Fields("Extra").Value = CBool(Me.Check1.Value) rsArtikel.Fields("EPREIS").Value = Format(Me.txtEPREIS.Text, "####.00") rsArtikel.Fields("Mwst").Value = Me.txtMwSt.Text rsArtikel.Fields("Bondrucker").Value = Me.ComboBonDrucker.Text rsArtikel.Fields("Stationsdrucker").Value = Me.ComboStationsDrucker.Text rsArtikel.Update ArtikelBearbeitenSpeichern = True Else ArtikelBearbeitenSpeichern = False End If Else 'Wenn Gericht vorhanden eintragen im Recordset MsgBox "gefunden" If MsgBox(" Die Daten wurden geändert. Möchten Sie die Daten trotzdem überschreiben", vbYesNo) = vbYes Then rsArtikel.Fields("WG").Value = Me.txtWarengruppe.Text rsArtikel.Fields("PLU").Value = Me.txtPLU.Text rsArtikel.Fields("Gericht").Value = Me.txtGericht.Text rsArtikel.Fields("Extra").Value = CBool(Me.Check1.Value) rsArtikel.Fields("EPREIS").Value = Format(Me.txtEPREIS.Text, "####.00") rsArtikel.Fields("Mwst").Value = Me.txtMwSt.Text rsArtikel.Fields("Bondrucker").Value = Me.ComboBonDrucker.Text rsArtikel.Fields("Stationsdrucker").Value = Me.ComboStationsDrucker.Text rsArtikel.Update ArtikelBearbeitenSpeichern = True Else ArtikelBearbeitenSpeichern = False End If End If Set rsArtikel = Nothing Set objConn = Nothing exit_Sub: On Error GoTo 0 Exit Function err_Handler: MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" Resume exit_Sub Set rsArtikel = Nothing Set objConn = Nothing End Function Function ArtikelNeuSpeichern() Set objConn = New ADODB.Connection Set rsArtikel = New ADODB.Recordset Dim strPath As String On Error GoTo err_Handler strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" Set objConn = New ADODB.Connection Set rsMain = New ADODB.Recordset With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & VarDatenbank .CursorLocation = adUseClient .Open End With With rsArtikel .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic '.Source = e Where Station='" & VarStation & "' and Tisch='" & VarTisch & "'" .Open "Select *FROM Artikelgruppe WHERE PLU ='" & Me.txtPLU.Text & "'" '.Find ("PLU='" & frmSpeisekarte.ListViewArtikelgruppe.SelectedItem.Text & "'") End With If rsArtikel.EOF = True Then 'Wenn kein Gericht vorhanden If MsgBox("Möchten Sie die neuen Daten Speichern", vbYesNo) = vbYes Then rsArtikel.AddNew rsArtikel.Fields("WG").Value = Me.txtWarengruppe.Text rsArtikel.Fields("PLU").Value = Me.txtPLU.Text rsArtikel.Fields("Gericht").Value = Me.txtGericht.Text rsArtikel.Fields("Extra").Value = CBool(Me.Check1.Value) rsArtikel.Fields("EPREIS").Value = Format(Me.txtEPREIS.Text, "####.00") rsArtikel.Fields("Mwst").Value = Me.txtMwSt.Text rsArtikel.Fields("Bondrucker").Value = Me.ComboBonDrucker.Text rsArtikel.Fields("Stationsdrucker").Value = Me.ComboStationsDrucker.Text rsArtikel.Update ArtikelNeuSpeichern = True Else ArtikelNeuSpeichern = False End If Else 'Wenn Gericht vorhanden eintragen im Recordset If MsgBox(" Die PLU = " & Me.txtPLU.Text & " ist bereits vorhanden. Möchten Sie die Daten trotzdem überschreiben", vbYesNo) = vbYes Then rsArtikel.Fields("WG").Value = Me.txtWarengruppe.Text rsArtikel.Fields("PLU").Value = Me.txtPLU.Text rsArtikel.Fields("Gericht").Value = Me.txtGericht.Text rsArtikel.Fields("Extra").Value = CBool(Me.Check1.Value) rsArtikel.Fields("EPREIS").Value = Format(Me.txtEPREIS.Text, "####.00") rsArtikel.Fields("Mwst").Value = Me.txtMwSt.Text rsArtikel.Fields("Bondrucker").Value = Me.ComboBonDrucker.Text rsArtikel.Fields("Stationsdrucker").Value = Me.ComboStationsDrucker.Text rsArtikel.Update ArtikelNeuSpeichern = True Else ArtikelNeuSpeichern = False End If End If Set rsArtikel = Nothing Set objConn = Nothing exit_Sub: On Error GoTo 0 Exit Function err_Handler: MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" Resume exit_Sub Set rsArtikel = Nothing Set objConn = Nothing End Function '---------Daten Löschen in Tabelle Artikelgruppe------------- Sub ArtikelLoeschen() Dim objConn As New ADODB.Connection Dim rsArtikel As New ADODB.Recordset Set objConn = New ADODB.Connection Set rsArtikel = New ADODB.Recordset Dim strPath As String On Error GoTo err_Handler strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" Set objConn = New ADODB.Connection Set rsMain = New ADODB.Recordset With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & VarDatenbank .CursorLocation = adUseClient .Open End With With rsArtikel .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic '.Source = e Where Station='" & VarStation & "' and Tisch='" & VarTisch & "'" .Open "Select WG,PLU,Gericht,EPREIS,MwSt FROM Artikelgruppe WHERE PLU ='" & frmSpeisekarte.ListViewArtikelgruppe.SelectedItem.Text & "'" '.Find ("PLU='" & frmSpeisekarte.ListViewArtikelgruppe.SelectedItem.Text & "'") End With If rsArtikel.EOF = False Then 'Wenn Gericht vorhanden 'Wenn Gericht vorhanden löschen Recordset If MsgBox("Möchten Sie die PLU = " & rsArtikel.Fields("PLU").Value & " mit allen zugehörigen Daten wirklich löschen", vbYesNo) = vbYes Then rsArtikel.Delete rsArtikel.Update End If End If Set rsArtikel = Nothing Set objConn = Nothing exit_Sub: On Error GoTo 0 Exit Sub err_Handler: MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" Resume exit_Sub Set rsArtikel = Nothing Set objConn = Nothing End Sub Sub StationenAbfragen() Dim objConn As New ADODB.Connection Dim rsStation As New ADODB.Recordset Set objConn = New ADODB.Connection Set rsStation = New ADODB.Recordset Dim strPath As String On Error GoTo err_Handler strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" Set objConn = New ADODB.Connection Set rsMain = New ADODB.Recordset With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & VarDatenbank .CursorLocation = adUseClient .Open End With With rsStation .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic '.Open "Select Station from Stationen Where Drucker ='" & VarPin2 & "'" .Open "Select Station from Stationen Where Drucker = True " End With Me.ComboStationsDrucker.AddItem "kein Drucker" While Not rsStation.EOF Me.ComboStationsDrucker.AddItem rsStation.Fields("Station").Value rsStation.MoveNext Wend Me.ComboStationsDrucker.Text = Me.ComboStationsDrucker.List(0) Set rsStation = Nothing Set objConn = Nothing exit_Sub: On Error GoTo 0 Exit Sub err_Handler: MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" Resume exit_Sub Set rsStation = Nothing Set objConn = Nothing End Sub