frmcustomer.frm

一套比较全面的茶馆控制系统软件源代码

  Call cmdCancel_Click
  
End Sub

Private Sub mnuDel_Click()

   Call cmdDel_Click
   
End Sub

Private Sub mnuOperater_Click()

  If Grid1.Text = "" Then
     cmdDel.Enabled = False
     mnuDel.Enabled = False
    Else
     cmdDel.Enabled = True
     mnuDel.Enabled = True
  End If
  
End Sub

Private Sub picCatalog_LostFocus()

  picCatalog.Visible = False
  
End Sub

Private Sub Text1_Change()

End Sub

Private Sub SSCommand1_Click()

 picPM.Visible = True
 Grid1PM.SetFocus
 
End Sub

Private Sub tpDate_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)

  DirectFocus txtSL, cmdAdd, tpDate, tpDate, KeyCode
  
End Sub

Private Sub tpDate_KeyDown(KeyCode As Integer, Shift As Integer)

  If KeyCode = 13 Then
     If cmdAdd.Enabled = True Then
        cmdAdd.Value = True
     End If
  End If
  
End Sub

Private Sub tpDate_KeyPress(KeyAscii As Integer)

  If KeyAscii = 13 Then
     If cmdAdd.Enabled = True Then
        cmdAdd.Value = True
     End If
  End If
  
End Sub

Private Sub txtCatalog_Change()

  If txtCatalog.Text = "" Or cmbPM.Text = "" Or Val(txtDJ.Text) = 0 Or Val(txtSL.Text) = 0 Then
     cmdAdd.Enabled = False
   Else
     cmdAdd.Enabled = True
  End If
  
End Sub

Private Sub txtCatalog_GotFocus()

  SetItFocus txtCatalog
  
End Sub

Private Sub txtCatalog_KeyDown(KeyCode As Integer, Shift As Integer)

  DirectFocus txtCatalog, cmbPM, txtCatalog, txtCatalog, KeyCode
  
End Sub

Private Sub txtCatalog_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 And Trim(txtCatalog) <> "" Then
    KeyAscii = 0
    cmbPM.SetFocus
  Else
    KeyAscii = 0
    cmdSelectUnit.Value = True
 End If
 
End Sub

Private Sub txtDJ_Change()
  
  If txtCatalog.Text = "" Or cmbPM.Text = "" Or Val(txtDJ.Text) = 0 Or Val(txtSL.Text) = 0 Then
     cmdAdd.Enabled = False
   Else
     cmdAdd.Enabled = True
  End If
  
End Sub

Private Sub txtDJ_GotFocus()
   
   txtDJ.SelStart = 0
   txtDJ.SelLength = Len(txtDJ)
   
End Sub

Private Sub txtDJ_KeyDown(KeyCode As Integer, Shift As Integer)

  DirectFocus cmbPM, txtSL, txtDJ, txtDJ, KeyCode
  
End Sub

Private Sub txtDJ_KeyPress(KeyAscii As Integer)

   If (KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = 8 Then
     Exit Sub
   Else
     KeyAscii = 0
   End If

End Sub

Private Sub txtDJ_LostFocus()
  
  If Val(txtDJ) = 0 Then
     txtDJ = sDJ
  End If

End Sub

Private Sub txtSl_Change()

  If txtCatalog.Text = "" Or cmbPM.Text = "" Or Val(txtDJ.Text) = 0 Or Val(txtSL.Text) = 0 Then
     cmdAdd.Enabled = False
   Else
     cmdAdd.Enabled = True
  End If
  
End Sub

Private Sub txtSl_GotFocus()

   txtSL.SelStart = 0
   txtSL.SelLength = Len(txtSL)
   
End Sub

Private Sub txtSL_KeyDown(KeyCode As Integer, Shift As Integer)

  If KeyCode = 39 Then  ' 向上
     txtSL = txtSL + 1
  End If
  If KeyCode = 37 Then ' 向下
     If txtSL > 1 Then txtSL = txtSL - 1
  End If
   
  DirectFocus txtDJ, tpDate, txtSL, txtSL, KeyCode
    
End Sub

Private Sub txtSl_KeyPress(KeyAscii As Integer)

   If (KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = 8 Then
     Exit Sub
   ElseIf KeyAscii = 13 Then
      If Val(txtSL) > 0 Then
         cmdAdd.Value = True  ' 添加
         KeyAscii = 0
      End If
    ElseIf KeyAscii = 43 Then '+时
      KeyAscii = 0
      cmdAdd.Value = True
     Else
     KeyAscii = 0
   End If

End Sub

Private Sub txtSL_LostFocus()

  If Val(txtSL) = 0 Then
     txtSL = "1"
  End If
  
End Sub

Private Sub DelRecord(sWP As String, sFields As String, sTable As String)

   On Error GoTo Err_del
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, Constr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Delete * From " & sTable & " Where " & sFields & "=" & sWP
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
        Exit Sub
Err_del:
 MsgBox "删除记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub AddRecord(sWP1 As String, sFields1 As String, sWP2 As String, sFields2 As String, _
     sWP3 As String, sFields3 As String, sWP4 As String, sFields4 As String, sWP5 As String, sFields5 As String, sWP6 As String, _
     sFields6 As String, sWP7 As String, sFields7 As String, sWP8 As String, sFields8 As String, sTable As String)

   On Error GoTo Err_Add
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, Constr)
   
   ' SQL语言删除
     sEXE = "Insert into " & sTable & " (" & sFields1 & "," & sFields2 & "," & sFields3 & "," & sFields4 & "," & sFields5 & "," & sFields6 & "," & sFields7 & "," & sFields8 & ") values('" _
            & sWP1 & "','" & sWP2 & "','" & sWP3 & "'," & sWP4 & ",'" & sWP5 & "'," & sWP6 & "," & sWP7 & ",#" & sWP8 & "#)"
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
        Exit Sub
Err_Add:
 MsgBox "添加记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Function GetPm(sPM As String) As String

   On Error GoTo Err_dj
   Dim DB As Database, EF As Recordset
    Set DB = OpenDatabase(ConData, False, False, Constr)
    
    Set EF = DB.OpenRecordset("Select * From EatList Where 代码='" & sPM & "'", dbOpenDynaset)
        
        If EF.BOF And EF.EOF Then
           GetPm = ""
         Else
           If Not IsNull(EF.Fields(1).Value) Then
              GetPm = EF.Fields(1).Value
           End If
        End If
         
    EF.Close
    DB.Close
      Exit Function
Err_dj:
 MsgBox "给出名称错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Function

Private Function GetCode(sPM As String) As String

   On Error GoTo Err_dj
   Dim DB As Database, EF As Recordset
    Set DB = OpenDatabase(ConData, False, False, Constr)
    'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
    
    Set EF = DB.OpenRecordset("Select * From EatList Where 名称='" & sPM & "'", dbOpenDynaset)
        
        If EF.BOF And EF.EOF Then
           GetCode = ""
         Else
           If Not IsNull(EF.Fields(4).Value) Then
              GetCode = EF.Fields(4).Value
           End If
        End If
         
    EF.Close
    DB.Close
      Exit Function
Err_dj:
 MsgBox "给出代码错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Function

Private Sub PastRecord(ID As Long, sFields As String)

   On Error GoTo Err_del
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, Constr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
      
   ' SQL语言删除
     sEXE = "Update Customer Set 状态='已送' Where " & sFields & "=" & ID
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
        Exit Sub
Err_del:
 MsgBox "更新已送错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub ConfigType()

   '配置网格
Grid1Type.Visible = False
Grid1Type.Cols = 1
Grid1Type.Clear
Grid1Type.FormatString = "^ 分 类 名 称 "
Grid1Type.ColWidth(0) = 1100

Dim DB As Database, EF As Recordset, HH As Integer
      
  
  Set DB = OpenDatabase(ConData, False, False, Constr)

    Set EF = DB.OpenRecordset("MenuType", dbOpenTable)
        Grid1Type.Rows = EF.RecordCount + 2
        
        If Grid1Type.Rows < 14 Then
           Grid1Type.Rows = 14
        End If
        
    Set EF = DB.OpenRecordset("Select * From MenuType", dbOpenDynaset)
        HH = 0
        Grid1Type.Col = 0
        Grid1Type.CellAlignment = 4  '居中
        Grid1Type.Text = "新建..."
        HH = 1
        Do While Not EF.EOF()
           Grid1Type.Row = HH
           Grid1Type.Col = 0
           Grid1Type.CellAlignment = 1
        If Not IsNull(EF.Fields(1).Value) Then
           Grid1Type.Text = EF.Fields(1).Value
        End If
          EF.MoveNext
          HH = HH + 1
        Loop
        DB.Close
 Grid1Type.Col = 0
 Grid1Type.Row = 1
 Grid1Type.ColSel = 0
 Grid1Type.Visible = True

End Sub

Private Sub QueryPM()
  
    ' 如果是代码时查询名称
    If GetPm(cmbPM) = "" Then  '没有此名称时
       '查询是否是代码
       If GetCode(cmbPM) = "" Then '退出
          ' 清空输入的内容
            cmbPM = ""  '名称为空
            txtDW = ""  '单位为空
            txtDJ = ""  '单价为空
            Exit Sub
         Else
            cmbPM = GetCode(cmbPM) '代码替代名称
       End If
    End If
    '查询到名称时
    txtDJ = GetDJ(cmbPM, txtCatalog)
    sDJ = txtDJ
    txtDW = sDW  '给出单位
 
End Sub

Private Sub Grid1PM_Click()
  
  If Grid1PM.Text = "" Then Exit Sub
 ' 新建类别
   If Grid1PM.Text = "新建..." Then
      frmOption1.Show 1
      '刷新数据
      ConfigPM (txtCatalog.Text)
      cmbPM.Text = sName
      picPM.Visible = False
      Exit Sub
    Else
      cmbPM.Text = Grid1PM.Text
      picPM.Visible = False
   End If
   
   txtDJ.SetFocus
   
End Sub

Private Sub Grid1PM_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
    '关闭
    Grid1PM_Click
    picPM.Visible = False
 End If
 If KeyAscii = 27 Then
    picPM.Visible = False
 End If

 txtDJ.SetFocus
 
End Sub

Public Sub UpDateIt(sCode As String, lSL As Long, lJE As Long)
   
   On Error Resume Next
  
   Dim DB As Database, EF As Recordset, HH As Integer
   Set DB = OpenDatabase(ConData, False, False, Constr)
   Set EF = DB.OpenRecordset("Select * From tmpEnterList Where 代码='" & sCode & "'", dbOpenDynaset)
       If EF.EOF And EF.BOF Then
          MsgBox "不能更新数据库，发生在重复添加时！    ", vbInformation, "提示：By Yusilong"
          EF.Close
          DB.Close
          Exit Sub
        Else
          EF.Edit
          EF.Fields(6).Value = EF.Fields(6).Value + lSL
          EF.Fields(7).Value = EF.Fields(7).Value + lJE
          EF.Update
       End If
    EF.Close
    DB.Close
    
End Sub