VERSION 5.00 Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDATGRD.OCX" Begin VB.Form frmTischUmbuchen BackColor = &H80000003& BorderStyle = 3 'Fester Dialog Caption = "Umbuchen" ClientHeight = 5175 ClientLeft = 105 ClientTop = 855 ClientWidth = 9825 FillStyle = 0 'Ausgefüllt BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000016& LinkMode = 1 'Quelle LinkTopic = "Form2" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 5175 ScaleWidth = 9825 ShowInTaskbar = 0 'False Begin VB.Timer TimerTischUmbuchen Enabled = 0 'False Interval = 50 Left = 960 Top = 4320 End Begin VB.CommandButton cmdNurMarkierungNachLinks BackColor = &H80000002& Caption = "<" Height = 480 Left = 4188 Style = 1 'Grafisch TabIndex = 5 Top = 2808 Width = 732 End Begin VB.CommandButton cmdAllesNachLinks BackColor = &H80000002& Caption = "<<" Height = 480 Left = 4176 Style = 1 'Grafisch TabIndex = 4 Top = 2112 Width = 732 End Begin VB.CommandButton cmdSchliessen BackColor = &H80000002& Caption = "Schließen" BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 585 Left = 7560 MaskColor = &H80000018& Style = 1 'Grafisch TabIndex = 6 Top = 4440 Width = 1845 End Begin VB.CommandButton cmdNurMarkierungNachRechts BackColor = &H80000002& Caption = ">" Height = 410 Left = 4164 Style = 1 'Grafisch TabIndex = 3 Top = 1308 UseMaskColor = -1 'True Width = 750 End Begin VB.CommandButton cmdAllesNachRechts BackColor = &H80000002& Caption = ">>" Height = 410 Left = 4176 Style = 1 'Grafisch TabIndex = 2 Top = 852 UseMaskColor = -1 'True Width = 750 End Begin MSDataGridLib.DataGrid DataGrid1 Height = 3495 Left = 480 TabIndex = 0 Top = 240 Width = 3150 _ExtentX = 5556 _ExtentY = 6165 _Version = 393216 AllowUpdate = -1 'True AllowArrows = -1 'True BackColor = 16777215 BorderStyle = 0 Enabled = -1 'True ForeColor = 128 HeadLines = 2 RowHeight = 20 WrapCellPointer = -1 'True RowDividerStyle = 6 BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Arial" Size = 11.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ColumnCount = 2 BeginProperty Column00 DataField = "" Caption = "" BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED} Type = 0 Format = "" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1031 SubFormatType = 0 EndProperty EndProperty BeginProperty Column01 DataField = "" Caption = "" BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED} Type = 0 Format = "" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1031 SubFormatType = 0 EndProperty EndProperty SplitCount = 1 BeginProperty Split0 RecordSelectors = 0 'False Size = 4455 BeginProperty Column00 EndProperty BeginProperty Column01 EndProperty EndProperty End Begin MSDataGridLib.DataGrid DataGrid2 Height = 3615 Left = 5760 TabIndex = 1 Top = 120 Width = 3150 _ExtentX = 5556 _ExtentY = 6376 _Version = 393216 AllowUpdate = -1 'True AllowArrows = -1 'True BackColor = 16777215 BorderStyle = 0 Enabled = -1 'True ForeColor = 128 HeadLines = 2 RowHeight = 20 WrapCellPointer = -1 'True RowDividerStyle = 6 BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Arial" Size = 11.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ColumnCount = 2 BeginProperty Column00 DataField = "" Caption = "" BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED} Type = 0 Format = "" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1031 SubFormatType = 0 EndProperty EndProperty BeginProperty Column01 DataField = "" Caption = "" BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED} Type = 0 Format = "" HaveTrueFalseNull= 0 FirstDayOfWeek = 0 FirstWeekOfYear = 0 LCID = 1031 SubFormatType = 0 EndProperty EndProperty SplitCount = 1 BeginProperty Split0 RecordSelectors = 0 'False Size = 4455 BeginProperty Column00 EndProperty BeginProperty Column01 EndProperty EndProperty End End Attribute VB_Name = "frmTischUmbuchen" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Dim VarStationUmbuchen, VarTischUmbuchen, VarKellnerUmbuchen '======================== FORMS EREIGNISSE ================== '============================================================ Private Sub Form_Load() Me.BackColor = &H80000003 Me.cmdAllesNachRechts.BackColor = &H80000002 Me.cmdNurMarkierungNachRechts.BackColor = &H80000002 Me.cmdAllesNachLinks.BackColor = &H80000002 Me.cmdNurMarkierungNachLinks.BackColor = &H80000002 Me.cmdSchliessen.BackColor = &H80000002 frmTastenBasis.Label1.Caption = "Umbuchen von Tisch " & VarTisch & " nach Tisch:" frmTastenBasis.Caption = "Umbuchen" frmTastenBasis.Show 1 Me.TimerTischUmbuchen.Enabled = True Select Case MDIHauptmenu.Tag Case "Abbrechen" Unload frmTischUmbuchen Exit Sub Case "OkLeer" frmTastenBasis.Show 1 Case "Unload" Unload frmTischUmbuchen Exit Sub End Select VarTischUmbuchen = MDIHauptmenu.Tag If VarTischUmbuchen = VarTisch Then Unload frmTischUmbuchen Exit Sub End If If VarTischUmbuchen < 1 Or VarTischUmbuchen > 10000000 Then MsgBox "Bitte geben Sie eine richtige Tischnummer ein." Unload frmTischUmbuchen Exit Sub End If If PicTischAbfragen(VarTischUmbuchen) = False Then 'Tisch existiert nicht Unload frmTischUmbuchen Exit Sub End If If StationBerechtigung(VarTischUmbuchen) = False Then 'Es gibt keine Berechtigung MsgBox "keine Berechtigung" Unload frmTischUmbuchen Exit Sub End If Abstand = MDIHauptmenu.ScaleHeight / 70 AbstandMitte = 8 * Abstand Me.Top = frmTisch.Top + cmdSchliessen.Height Me.Left = frmTisch.Left Me.Width = frmTisch.Width + frmTastenMenu1.Width Me.Height = 1.8 * frmTisch.Height DataGrid1.Top = Abstand DataGrid1.Left = Abstand DataGrid1.Width = Me.ScaleWidth / 2 - AbstandMitte / 2 - 2 * Abstand DataGrid1.Height = Me.ScaleHeight - 2 * cmdSchliessen.Height DataGrid1.RowHeight = DataGrid1.Height / 20 'DataGrid1.Align = 3 DataGrid2.Top = Abstand DataGrid2.Left = DataGrid1.Left + DataGrid1.Width + AbstandMitte + 2 * Abstand DataGrid2.Width = DataGrid1.Width DataGrid2.Height = DataGrid1.Height DataGrid2.RowHeight = DataGrid1.Height / 20 Me.cmdAllesNachRechts.Width = AbstandMitte - 1.5 * Abstand Me.cmdAllesNachRechts.Height = 5 * Abstand Me.cmdAllesNachRechts.Top = Me.DataGrid1.Top + Me.DataGrid1.Height / 4 - (2 * Me.cmdAllesNachRechts.Height + Abstand) / 3 Me.cmdAllesNachRechts.Left = Me.DataGrid1.Left + Me.DataGrid1.Width + 2 * Abstand Me.cmdNurMarkierungNachRechts.Top = Me.cmdAllesNachRechts.Top + Me.cmdAllesNachRechts.Height + 0.8 * Abstand Me.cmdNurMarkierungNachRechts.Left = Me.cmdAllesNachRechts.Left Me.cmdNurMarkierungNachRechts.Width = Me.cmdAllesNachRechts.Width Me.cmdNurMarkierungNachRechts.Height = Me.cmdAllesNachRechts.Height cmdAllesNachLinks.Top = Me.DataGrid1.Top + Me.DataGrid1.Height / 2 + (2 * Me.cmdAllesNachRechts.Height + Abstand) / 3 cmdAllesNachLinks.Left = cmdNurMarkierungNachRechts.Left cmdAllesNachLinks.Width = cmdNurMarkierungNachRechts.Width cmdAllesNachLinks.Height = cmdNurMarkierungNachRechts.Height cmdNurMarkierungNachLinks.Top = cmdAllesNachLinks.Top + cmdAllesNachLinks.Height + 0.8 * Abstand cmdNurMarkierungNachLinks.Left = cmdAllesNachLinks.Left cmdNurMarkierungNachLinks.Width = cmdAllesNachLinks.Width cmdNurMarkierungNachLinks.Height = cmdAllesNachLinks.Height cmdSchliessen.Top = DataGrid1.Top + DataGrid1.Height + cmdSchliessen.Height / 3 cmdSchliessen.Left = (Me.ScaleWidth - cmdSchliessen.Width) / 2 cmdSchliessen.Height = 0.8 * Me.cmdAllesNachRechts.Height Call Me.TischLokalAktualisieren(DataGrid1, VarStation, VarTisch) Call Me.TischLokalAktualisieren(DataGrid2, VarStationUmbuchen, VarTischUmbuchen) End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.cmdAllesNachRechts.BackColor = &H80000002 Me.cmdNurMarkierungNachRechts.BackColor = &H80000002 Me.cmdAllesNachLinks.BackColor = &H80000002 Me.cmdNurMarkierungNachLinks.BackColor = &H80000002 Me.cmdSchliessen.BackColor = &H80000002 End Sub Private Sub Form_Paint() 'DataGrid1.Scroll 0, 1000 End Sub Private Sub Form_Unload(Cancel As Integer) Call mdlDatenbanken.TischAktualisieren(VarTisch, frmTisch.cmdTisch.Caption) Me.TimerTischUmbuchen.Enabled = False End Sub '======================== COMMANDBUTTON EREIGNISSE ================== '==================================================================== Private Sub cmdAllesNachLinks_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.cmdAllesNachRechts.BackColor = &H80000002 Me.cmdNurMarkierungNachRechts.BackColor = &H80000002 Me.cmdAllesNachLinks.BackColor = &H80C0FF Me.cmdNurMarkierungNachLinks.BackColor = &H80000002 Me.cmdSchliessen.BackColor = &H80000002 End Sub Private Sub cmdAllesNachRechts_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.cmdAllesNachRechts.BackColor = &H80C0FF Me.cmdNurMarkierungNachRechts.BackColor = &H80000002 Me.cmdAllesNachLinks.BackColor = &H80000002 Me.cmdNurMarkierungNachLinks.BackColor = &H80000002 Me.cmdSchliessen.BackColor = &H80000002 End Sub Private Sub cmdNurMarkierungNachRechts_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.cmdAllesNachRechts.BackColor = &H80000002 Me.cmdNurMarkierungNachRechts.BackColor = &H80C0FF Me.cmdAllesNachLinks.BackColor = &H80000002 Me.cmdNurMarkierungNachLinks.BackColor = &H80000002 Me.cmdSchliessen.BackColor = &H80000002 End Sub Private Sub cmdNurMarkierungNachLinks_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.cmdAllesNachRechts.BackColor = &H80000002 Me.cmdNurMarkierungNachRechts.BackColor = &H80000002 Me.cmdAllesNachLinks.BackColor = &H80000002 Me.cmdNurMarkierungNachLinks.BackColor = &H80C0FF Me.cmdSchliessen.BackColor = &H80000002 End Sub Private Sub cmdSchliessen_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.cmdAllesNachRechts.BackColor = &H80000002 Me.cmdNurMarkierungNachRechts.BackColor = &H80000002 Me.cmdAllesNachLinks.BackColor = &H80000002 Me.cmdNurMarkierungNachLinks.BackColor = &H80000002 Me.cmdSchliessen.BackColor = &H80C0FF End Sub Private Sub cmdSchliessen_Click() Unload Me End Sub Private Sub cmdAllesNachRechts_Click() 'On Error Resume Next Call AllesUmbuchen(DataGrid2, VarStation, VarStationUmbuchen, VarTisch, VarTischUmbuchen) Call Me.TischLokalAktualisieren(DataGrid1, VarStation, VarTisch) Call Me.TischLokalAktualisieren(DataGrid2, VarStationUmbuchen, VarTischUmbuchen) Me.DataGrid2.SetFocus End Sub Private Sub cmdAllesNachLinks_Click() 'On Error Resume Next Call AllesUmbuchen(DataGrid1, VarStationUmbuchen, VarStation, VarTischUmbuchen, VarTisch) Call Me.TischLokalAktualisieren(DataGrid1, VarStation, VarTisch) Call Me.TischLokalAktualisieren(DataGrid2, VarStationUmbuchen, VarTischUmbuchen) Me.DataGrid1.SetFocus End Sub Private Sub cmdNurMarkierungNachRechts_Click() 'On Error Resume Next If Me.DataGrid1.Row = -1 Then Exit Sub If Me.DataGrid1.Columns("Extra").Text = "Ja" And Not Me.DataGrid1.Columns("PLU").Text = "" Then Call NurGerichtUmbuchenExtraNichtGleich(VarStation, VarStationUmbuchen, VarTisch, VarTischUmbuchen, Me.DataGrid1.Columns("RegID").Text) ElseIf Me.DataGrid1.Columns("Extra").Text = "Nein" Then Call NurGerichtUmbuchen(VarStation, VarStationUmbuchen, VarTisch, VarTischUmbuchen, Me.DataGrid1.Columns("PLU").Text, Format(Me.DataGrid1.Columns("E-Preis").Text, "0.00")) Else Exit Sub End If Call Me.TischLokalAktualisieren(DataGrid1, VarStation, VarTisch) Call Me.TischLokalAktualisieren(DataGrid2, VarStationUmbuchen, VarTischUmbuchen) Me.DataGrid1.SetFocus End Sub Private Sub cmdNurMarkierungNachLinks_Click() On Error Resume Next Call NurGerichtUmbuchen(VarStationUmbuchen, VarStation, VarTischUmbuchen, VarTisch, Me.DataGrid2.Columns("PLU").Text, Format(Me.DataGrid2.Columns("E-Preis").Text, "0.00")) Call Me.TischLokalAktualisieren(DataGrid1, VarStation, VarTisch) Call Me.TischLokalAktualisieren(DataGrid2, VarStationUmbuchen, VarTischUmbuchen) Me.DataGrid2.SetFocus End Sub '======================== DataGrid EREIGNISSE ================== '=============================================================== Private Sub DataGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer) On Error Resume Next If DataGrid1.SelBookmarks.Count <> 0 Then DataGrid1.SelBookmarks.Remove 0 DataGrid1.SelBookmarks.Add DataGrid1.Bookmark DataGrid1.Col = 0 'so kann nichts eingetragen werden End Sub Private Sub DataGrid1_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next If DataGrid1.SelBookmarks.Count <> 0 Then DataGrid1.SelBookmarks.Remove 0 DataGrid1.SelBookmarks.Add DataGrid1.Bookmark DataGrid1.Col = 0 'so kann nichts eingetragen werden End Sub Private Sub Datagrid2_RowColChange(LastRow As Variant, ByVal LastCol As Integer) On Error Resume Next If DataGrid2.SelBookmarks.Count <> 0 Then DataGrid2.SelBookmarks.Remove 0 DataGrid2.SelBookmarks.Add DataGrid2.Bookmark DataGrid2.Col = 0 'so kann nichts eingetragen werden End Sub Private Sub DataGrid2_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next If DataGrid2.SelBookmarks.Count <> 0 Then DataGrid2.SelBookmarks.Remove 0 DataGrid2.SelBookmarks.Add DataGrid2.Bookmark DataGrid2.Col = 0 'so kann nichts eingetragen werden End Sub '======================== TIMER EREIGNISSE ================== '=============================================================== Private Sub TimerTischUmbuchen_Timer() Dim X As Long For X = 48 To 90 If CompKeyTimerTischUmbuchen(X, UCase(Chr$(X))) Then Exit Sub If CompKeyTimerTischUmbuchen(X + 48, UCase(Chr$(X))) Then Exit Sub Next X If CompKeyTimerTischUmbuchen(8, "BACKSPACE") Then Exit Sub If CompKeyTimerTischUmbuchen(9, "TAB") Then Exit Sub If CompKeyTimerTischUmbuchen(13, "ENTER") Then Exit Sub If CompKeyTimerTischUmbuchen(16, "SHIFT") Then Exit Sub If CompKeyTimerTischUmbuchen(17, "STRG") Then Exit Sub If CompKeyTimerTischUmbuchen(18, "ALT") Then Exit Sub If CompKeyTimerTischUmbuchen(19, "PAUSE") Then Exit Sub If CompKeyTimerTischUmbuchen(27, "ESC") Then Exit Sub If CompKeyTimerTischUmbuchen(33, "PAGE UP") Then Exit Sub If CompKeyTimerTischUmbuchen(34, "PAGE DOWN") Then Exit Sub If CompKeyTimerTischUmbuchen(35, "ENDE") Then Exit Sub If CompKeyTimerTischUmbuchen(36, "POS1") Then Exit Sub If CompKeyTimerTischUmbuchen(37, "LEFT") Then Exit Sub If CompKeyTimerTischUmbuchen(38, "UP") Then Exit Sub If CompKeyTimerTischUmbuchen(39, "RIGHT") Then Exit Sub If CompKeyTimerTischUmbuchen(40, "DOWN") Then Exit Sub If CompKeyTimerTischUmbuchen(44, "DRUCK") Then Exit Sub If CompKeyTimerTischUmbuchen(45, "INSERT") Then Exit Sub If CompKeyTimerTischUmbuchen(46, "DEL") Then Exit Sub If CompKeyTimerTischUmbuchen(144, "NUM") Then Exit Sub If CompKeyTimerTischUmbuchen(145, "ROLLEN") Then Exit Sub For X = 112 To 127 If CompKeyTimerTischUmbuchen(X, "F" & CStr(X - 111)) Then Exit Sub Next X ' usw... usw... End Sub '======================== PROZEDUREN ================== '=============================================================== Sub TischLokalAktualisieren(VarTabelle, VarStationLokal, VarTischLokal) Dim objConn As New ADODB.Connection Dim rsTisch As New ADODB.Recordset Dim strPath As String Set objConn = New ADODB.Connection Set rsTisch = New ADODB.Recordset strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & strPath & "asql.mdb" .CursorLocation = adUseClient .Open End With 'Überprüfen ob Tisch vorhanden With rsTisch .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select *FROM OffeneTische Where Tisch='" & VarTischLokal & "' and TischDetails='Alt' ORDER BY RegID,ID " End With If rsTisch.EOF = True Then 'Datensatz wurde nicht gefunden VarKellnerLokal = VarKellner Else VarKellnerLokal = rsTisch.Fields("Kellner").Value End If VarKellnerUmbuchen = VarKellnerLokal Set VarTabelle.DataSource = rsTisch VarTabelle.LeftCol = 1 For I = 0 To VarTabelle.Columns.Count - 1 VarTabelle.Columns.Item(I).Visible = False Next I VarTabelle.Columns("EPREIS").Caption = "E-Preis" VarTabelle.Columns("GPREIS").Caption = "G-Preis" VarTabelle.Columns("Menge_Text").Caption = "Anz." VarTabelle.Columns("PLU").Visible = True VarTabelle.Columns("Anz.").Visible = True VarTabelle.Columns("Gericht").Visible = True VarTabelle.Columns("E-Preis").Visible = True VarTabelle.Columns("G-Preis").Visible = True VarTabelle.Columns("PLU").Width = 0.09 * VarTabelle.Width VarTabelle.Columns("Anz.").Width = 0.08 * VarTabelle.Width VarTabelle.Columns("Anz.").DividerStyle = 0 VarTabelle.Columns("Gericht").Width = 0.51 * VarTabelle.Width VarTabelle.Columns("E-Preis").Width = 0.16 * VarTabelle.Width VarTabelle.Columns("G-Preis").Width = 0.16 * VarTabelle.Width VarTabelle.Columns("PLU").Alignment = dbgCenter VarTabelle.Columns("Anz.").Alignment = dbgCenter VarTabelle.Columns("E-Preis").Alignment = dbgRight VarTabelle.Columns("G-Preis").Alignment = dbgRight If VarTabelle.Row >= 0 Then VarTabelle.Scroll 0, 1000 VarTabelle.Row = VarTabelle.VisibleRows - 1 'Selection modus setzen If VarTabelle.SelBookmarks.Count <> 0 Then VarTabelle.SelBookmarks.Remove 0 VarTabelle.SelBookmarks.Add VarTabelle.Bookmark 'SendKeys "{ESC}" End If Call TischSumme(VarTabelle, VarStationLokal, VarTischLokal, VarKellnerLokal) Set rsTisch = Nothing Set objConn = Nothing End Sub Sub TischSumme(VarTabelle, VarStationLokal, VarTischLokal, VarKellnerLokal) Dim objConn As New ADODB.Connection Dim rsSummeTisch As New ADODB.Recordset Dim strPath As String Set objConn = New ADODB.Connection Set rsSummeTisch = New ADODB.Recordset On Error GoTo err_Handler strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & strPath & "asql.mdb" .CursorLocation = adUseClient .Open End With With rsSummeTisch .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Source = "Select Sum(Menge*EPREIS) As SummeTisch FROM OffeneTische " .Open End With VarTabelle.Caption = VarStationLokal & " " & "Tisch: " & VarTischLokal 'Formatierung von Datagrid1 Tabelle vornehmen Set fmt = New StdDataFormat fmt.Type = fmtCustom fmt.Format = "Currency" '"###,##0.00" Set VarTabelle.Columns("E-Preis").DataFormat = fmt Set VarTabelle.Columns("G-Preis").DataFormat = fmt Set objConn = Nothing Set rsSummeTisch = Nothing Set fmt = Nothing exit_Sub: On Error GoTo 0 Exit Sub err_Handler: MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" VarTabelle.ReBind Resume exit_Sub Set objConn = Nothing Set rsSummeTisch = Nothing End Sub Sub AllesUmbuchen(VarTabelle, VarStationVon, VarStationNach, VarTischVon, VarTischNach) Dim objConn As ADODB.Connection Dim rsTischVon As ADODB.Recordset Dim rsTischNach As ADODB.Recordset Dim strPath As String Set objConn = New ADODB.Connection Set rsTischVon = New ADODB.Recordset Set rsTischNach = New ADODB.Recordset strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" On Error GoTo err_Handler With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & strPath & "asql.mdb" .CursorLocation = adUseClient .Open End With 'Tabelle OffeneTische öffnen With rsTischVon .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select *From OffeneTische Where Station = '" & VarStationVon & "' and Tisch='" & VarTischVon & "' and TischDetails='Alt'" End With 'Recordset durchlaufen und neu Eintäge löschen. While Not rsTischVon.EOF With rsTischNach .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select *From OffeneTische Where Station = '" & VarStationNach & "' and Tisch='" & VarTischNach & "' and TischDetails='Alt' and PLU_ID='" & rsTischVon.Fields("PLU_ID").Value & "' and EPREIS='" & rsTischVon.Fields("EPreis").Value & "'" End With If rsTischNach.EOF Then rsTischNach.AddNew For k = 1 To rsTischNach.Fields.Count - 1 rsTischNach.Fields(k).Value = rsTischVon.Fields(k).Value Next k rsTischNach.Fields("Tisch").Value = VarTischNach rsTischNach.Fields("station").Value = VarStationNach Else If rsTischNach.Fields("Extra").Value = "Ja" Then rsTischNach.AddNew For k = 1 To rsTischNach.Fields.Count - 1 rsTischNach.Fields(k).Value = rsTischVon.Fields(k).Value Next k rsTischNach.Fields("Tisch").Value = VarTischNach rsTischNach.Fields("station").Value = VarStationNach Else rsTischNach.Fields("Menge").Value = rsTischNach.Fields("Menge").Value + rsTischVon.Fields("Menge").Value rsTischNach.Fields("Menge_Text").Value = rsTischNach.Fields("Menge").Value & "x" rsTischNach.Fields("GPreis").Value = Format(rsTischNach.Fields("Menge").Value * rsTischNach.Fields("EPreis").Value, "####0.#0") End If End If rsTischNach.Update 'Datenbank Aktualisieren rsTischNach.Close rsTischVon.Delete rsTischVon.MoveNext Wend 'Objekte aus dem Speicher leeren Set rsTischVon = Nothing Set rsTischNach = Nothing Set objConn = Nothing exit_Sub: On Error GoTo 0 Set rsTischVon = Nothing Set rsTischNach = Nothing Set objConn = Nothing Exit Sub err_Handler: MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" Resume exit_Sub Set rsTischVon = Nothing Set rsTischNach = Nothing Set objConn = Nothing End Sub Sub NurGerichtUmbuchen(VarStationVon, VarStationNach, VarTischVon, VarTischNach, VarPLU, VarEPREIS) Dim Wert As Integer Dim objConn As ADODB.Connection Dim rsTischVon As ADODB.Recordset Dim rsTischNach As ADODB.Recordset Set objConn = New ADODB.Connection Set rsTischVon = New ADODB.Recordset Set rsTischNach = New ADODB.Recordset Dim strPath As String On Error GoTo err_Handler strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & strPath & "asql.mdb" .CursorLocation = adUseClient .Open End With With rsTischVon .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select *FROM OffeneTische Where Station = '" & VarStationVon & "' and Tisch='" & VarTischVon & "' and TischDetails='Alt' and PLU='" & VarPLU & "' and EPREIS='" & VarEPREIS & "'" End With With rsTischNach .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select *FROM OffeneTische Where Station = '" & VarStationNach & "' and Tisch='" & VarTischNach & "' and TischDetails='Alt' and PLU='" & VarPLU & "' and EPREIS='" & VarEPREIS & "'" End With If rsTischVon.EOF = True Then 'Bedingung 1 Starten MsgBox "Tisch ist Leer" Else If rsTischVon.Fields("Menge").Value = 1 Then 'Bedingung 2 Starten If rsTischNach.EOF = True Then rsTischVon.Fields("Tisch").Value = VarTischNach rsTischVon.Fields("Station").Value = VarStationNach rsTischVon.Update 'Aktualisiert das Recordset rsTischVon.Requery 'Aktualisiert die Datenbank Else rsTischNach.Fields("Menge").Value = rsTischNach.Fields("Menge").Value + rsTischVon.Fields("Menge").Value rsTischNach.Fields("Menge_Text").Value = rsTischNach.Fields("Menge").Value & "x" rsTischNach.Fields("GPREIS").Value = Format(rsTischNach.Fields("Menge").Value * rsTischNach.Fields("EPREIS").Value, "####0.00") rsTischVon.Delete rsTischVon.Update 'Aktualisiert das Recordset rsTischVon.Requery 'Aktualisiert die Datenbank rsTischNach.Update 'Aktualisiert das Recordset rsTischNach.Requery 'Aktualisiert die Datenbank End If Else frmTastenBasis.Label1.Caption = "Bitte Anzahl eingeben" frmTastenBasis.Show 1 Select Case MDIHauptmenu.Tag Case "Abbrechen" Exit Sub Case "OkLeer" frmTastenBasis.Show 1 Case "Unload" Exit Sub End Select Wert = MDIHauptmenu.Tag If Wert > 0 And Wert < rsTischVon.Fields("Menge").Value Then 'Bedingung 3 Starten If rsTischNach.EOF = True Then 'Das ist kein satz vorhanden rsTischNach.AddNew For I = 1 To rsTischNach.Fields.Count - 1 rsTischNach.Fields(I).Value = rsTischVon.Fields(I).Value Next I rsTischVon.Fields("Menge").Value = rsTischVon.Fields("Menge").Value - Wert rsTischVon.Fields("Menge_Text").Value = rsTischVon.Fields("Menge").Value & "x" rsTischVon.Fields("GPREIS").Value = Format(rsTischVon.Fields("Menge").Value * rsTischVon.Fields("EPREIS").Value, "####0.00") rsTischNach.Fields("Menge").Value = Wert rsTischNach.Fields("Menge_Text").Value = rsTischNach.Fields("Menge").Value & "x" rsTischNach.Fields("GPREIS").Value = Format(rsTischNach.Fields("Menge").Value * rsTischNach.Fields("EPREIS").Value, "####0.00") rsTischNach.Fields("Tisch").Value = VarTischNach rsTischNach.Fields("Station").Value = VarStationNach rsTischVon.Update 'Aktualisiert das Recordset rsTischNach.Update 'Aktualisiert das Recordset Else 'Satz ist vorhanden rsTischVon.Fields("Menge").Value = rsTischVon.Fields("Menge").Value - Wert rsTischVon.Fields("Menge_Text").Value = rsTischVon.Fields("Menge").Value & "x" rsTischVon.Fields("GPREIS").Value = Format(rsTischVon.Fields("Menge").Value * rsTischVon.Fields("EPREIS").Value, "####0.00") rsTischNach.Fields("Menge").Value = rsTischNach.Fields("Menge").Value + Wert rsTischNach.Fields("Menge_Text").Value = rsTischNach.Fields("Menge").Value & "x" sTischNach.Fields("GPREIS").Value = Format(rsTischNach.Fields("Menge").Value * rsTischNach.Fields("EPREIS").Value, "####0.00") rsTischVon.Update 'Aktualisiert das Recordset rsTischNach.Update 'Aktualisiert das Recordset End If rsTischVon.Update 'Aktualisiert das Recordset rsTischVon.Requery 'Aktualisiert die Datenbank ElseIf Wert = rsTischVon.Fields("Menge").Value Then If rsTischNach.EOF = True Then rsTischVon.Fields("Tisch").Value = VarTischNach rsTischVon.Fields("Station").Value = VarStationNach rsTischVon.Update 'Aktualisiert das Recordset rsTischVon.Requery 'Aktualisiert die Datenbank Else rsTischNach.Fields("Menge").Value = rsTischNach.Fields("Menge").Value + rsTischVon.Fields("Menge").Value rsTischNach.Fields("Menge_Text").Value = rsTischNach.Fields("Menge").Value & "x" rsTischNach.Fields("GPREIS").Value = Format(rsTischNach.Fields("Menge").Value * rsTischNach.Fields("EPREIS").Value, "####0.00") rsTischVon.Delete rsTischVon.Update 'Aktualisiert das Recordset rsTischVon.Requery 'Aktualisiert die Datenbank rsTischNach.Update 'Aktualisiert das Recordset rsTischNach.Requery 'Aktualisiert die Datenbank End If End If 'Bedingung 3 abschließen End If 'Bedingung 2 abschließen End If 'Bedingung 1 abschließen Set rsTischNach = Nothing Set rsTischVon = Nothing Set objConn = Nothing exit_Sub: On Error GoTo 0 Exit Sub err_Handler: If Err.Number <> 13 Then MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" End If Resume exit_Sub Set rsTischNach = Nothing Set rsTischVon = Nothing Set rsTischNeu = Nothing End Sub Sub NurGerichtUmbuchenExtraNichtGleich(VarStationVon, VarStationNach, VarTischVon, VarTischNach, VarRegIDLokal) Dim Wert As Integer Dim objConn As ADODB.Connection Dim rsTischVon As ADODB.Recordset Dim rsTischNach As ADODB.Recordset Set objConn = New ADODB.Connection Set rsTischVon = New ADODB.Recordset Set rsTischNach = New ADODB.Recordset Dim strPath As String On Error GoTo err_Handler strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & strPath & "asql.mdb" .CursorLocation = adUseClient .Open End With With rsTischVon .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select *FROM OffeneTische Where Station = '" & VarStationVon & "' and Tisch='" & VarTischVon & "' and TischDetails='Alt' and RegID=" & VarRegIDLokal & "" End With With rsTischNach .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select *FROM OffeneTische Where Station = '" & VarStationNach & "' and Tisch='" & VarTischNach & "' and TischDetails='Alt'" End With If rsTischVon.EOF = True Then 'Bedingung 1 Starten MsgBox "Gericht nicht gefunden oder Tisch ist Leer" Else If rsTischVon.Fields("Menge").Value = 1 Then 'Bedingung 2 Starten While Not rsTischVon.EOF rsTischVon.Fields("Tisch").Value = VarTischNach rsTischVon.Fields("Station").Value = VarStationNach rsTischVon.Update 'Aktualisiert das Recordset rsTischVon.MoveNext Wend Else frmTastenBasis.Label1.Caption = "Bitte Anzahl eingeben" frmTastenBasis.Show 1 Select Case MDIHauptmenu.Tag Case "Abbrechen" Exit Sub Case "OkLeer" frmTastenBasis.Show 1 Case "Unload" Exit Sub End Select Wert = MDIHauptmenu.Tag If Wert > 0 And Wert < rsTischVon.Fields("Menge").Value Then 'Bedingung 3 Starten While Not rsTischVon.EOF 'Das ist kein satz vorhanden rsTischNach.AddNew For I = 1 To rsTischNach.Fields.Count - 1 rsTischNach.Fields(I).Value = rsTischVon.Fields(I).Value Next I rsTischVon.Fields("Menge").Value = rsTischVon.Fields("Menge").Value - Wert rsTischVon.Fields("GPREIS").Value = Format(rsTischVon.Fields("Menge").Value * rsTischVon.Fields("EPREIS").Value, "####0.00") rsTischNach.Fields("Menge").Value = Wert rsTischNach.Fields("GPREIS").Value = Format(rsTischNach.Fields("Menge").Value * rsTischNach.Fields("EPREIS").Value, "####0.00") rsTischNach.Fields("Tisch").Value = VarTischNach rsTischNach.Fields("Station").Value = VarStationNach If Not IsNull(rsTischVon.Fields("PLU").Value) = True Then rsTischVon.Fields("Menge_Text").Value = rsTischVon.Fields("Menge").Value & "x" rsTischNach.Fields("Menge_Text").Value = rsTischNach.Fields("Menge").Value & "x" Else VarZeichenfolge = Mid(rsTischVon.Fields("Gericht").Value, 5) rsTischVon.Fields("Gericht").Value = "+ " & rsTischVon.Fields("Menge").Value & "x " & VarZeichenfolge rsTischNach.Fields("Gericht").Value = "+ " & rsTischNach.Fields("Menge").Value & "x " & VarZeichenfolge End If rsTischVon.Update 'Aktualisiert das Recordset rsTischNach.Update 'Aktualisiert das Recordset rsTischVon.MoveNext Wend ElseIf Wert = rsTischVon.Fields("Menge").Value Then While Not rsTischVon.EOF rsTischNach.AddNew For I = 1 To rsTischNach.Fields.Count - 1 rsTischNach.Fields(I).Value = rsTischVon.Fields(I).Value Next I rsTischNach.Fields("Tisch").Value = VarTischNach rsTischNach.Fields("Station").Value = VarStationNach rsTischNach.Update 'Aktualisiert das Recordset rsTischVon.Delete rsTischVon.Update 'Aktualisiert das Recordset rsTischVon.MoveNext Wend End If 'Bedingung 3 abschließen End If 'Bedingung 2 abschließen End If 'Bedingung 1 abschließen Set rsTischNach = Nothing Set rsTischVon = Nothing Set objConn = Nothing exit_Sub: On Error GoTo 0 Exit Sub err_Handler: If Err.Number <> 13 Then MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _ vbCritical, "Fehler" End If Resume exit_Sub Set rsTischNach = Nothing Set rsTischVon = Nothing Set rsTischNeu = Nothing End Sub Function PicTischAbfragen(VarTischUmbuchen) As Boolean Dim objConn As New ADODB.Connection Dim rsPicTisch As New ADODB.Recordset Dim strPath As String Set objConn = New ADODB.Connection Set rsPicTisch = New ADODB.Recordset strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & strPath & "asql.mdb" .CursorLocation = adUseClient .Open End With 'Überprüfen ob Tisch vorhanden With rsPicTisch .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select Station,Name from TabellePicTisch Where Name = '" & VarTischUmbuchen & "'" '.Find ("Name = '" & VarTischUmbuchen & "'") End With If rsPicTisch.EOF = False Then 'Datensatz wurde gefunden 'Datensatz wurde gefunden(Tisch ist vorhanden) VarStationUmbuchen = rsPicTisch.Fields("Station").Value Call Me.TischLokalAktualisieren(DataGrid2, VarStationUmbuchen, VarTischUmbuchen) PicTischAbfragen = True Else MsgBox "Dieser Tisch existiert nicht." PicTischAbfragen = False End If Set rsPicTisch = Nothing Set objConn = Nothing End Function Function StationBerechtigung(VarTischUmbuchen) As Boolean Dim objConn As New ADODB.Connection Dim rsBerechtigung As New ADODB.Recordset Dim strPath As String Set objConn = New ADODB.Connection Set rsBerechtigung = New ADODB.Recordset strPath = App.Path If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" With objConn .Provider = "Microsoft Jet 4.0 OLE DB Provider" .Properties("Jet OLEDB:Database Password") = VarPasswordDatenbank .ConnectionString = "Data Source=" & strPath & "asql.mdb" .CursorLocation = adUseClient .Open End With 'Überprüfen ob Tisch vorhanden With rsBerechtigung .ActiveConnection = objConn .CursorLocation = adUseClient .LockType = adLockOptimistic .Open "Select *from Kellner Where Mitarbeiter = '" & VarKellner & "'" '.Find ("Name = '" & VarTischUmbuchen & "'") End With If rsBerechtigung.EOF = True Then 'Datensatz wurde nicht gefunden 'VarStationUmbuchen = rsBerechtigung.Fields("Station").Value StationBerechtigung = False Else For I = 0 To rsBerechtigung.Fields.Count - 1 If rsBerechtigung.Fields.Item(I).Name = VarStationUmbuchen Then If rsBerechtigung.Fields.Item(I).Value = True Then 'MsgBox "True heist aktiviert." StationBerechtigung = True Else 'MsgBox "True heist deaktiviert." StationBerechtigung = False End If End If Next I End If Set rsBerechtigung = Nothing Set objConn = Nothing End Function