frmbackit.frm

星级酒店管理系统（附带系统自写控件源码）

     txtDJ = Grid1X.TextMatrix(Grid1X.Row, 4)
     txtUnit = Grid1X.TextMatrix(Grid1X.Row, 5)
     txtType = Grid1X.TextMatrix(Grid1X.Row, 6)
     txtJGF = 0
     AddIt = False
  End If

End Sub

Private Sub Grid1X_DblClick()

  '双击将该值送给详细项目
  If Trim(Grid1X.Text) <> "" Then '有物品时
     AddIt = True
     cmbCode.Text = Grid1X.TextMatrix(Grid1X.Row, 1)
     txtPingyin = Grid1X.TextMatrix(Grid1X.Row, 2)
     txtName = Grid1X.TextMatrix(Grid1X.Row, 3)
     txtSL = 1
     txtDJ = Grid1X.TextMatrix(Grid1X.Row, 4)
     txtUnit = Grid1X.TextMatrix(Grid1X.Row, 5)
     txtType = Grid1X.TextMatrix(Grid1X.Row, 6)
     txtJGF = 0
     If cmdAdd.Enabled = True Then cmdAdd.Value = True
     AddIt = False
  End If
  
End Sub

Private Sub txtBXF_Change()

  If txtBXF.Text = "" Then
     txtBXF = 0
  End If
  
End Sub

Private Sub Grid1X_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    '回车时
     Call Grid1X_DblClick
 End If
 
End Sub

Private Sub txtDH_Change()

  If Trim(txtDH.Text) = sDNumber Then '单号相等时
     cmdSave.Enabled = False
    ElseIf Trim(txtDH.Text) <> "" Then
     cmdSave.Enabled = True
  End If
  
End Sub

Private Sub txtJGF_Change()

  If txtJGF.Text = "" Then
     txtJGF = 0
  End If
  
End Sub

Private Sub txtPingyin_Change()
 
 If AddIt = False Then
    sGlobalType = ""
    'Strip1.Tabs.Item("ALL").Selected = True
    ConfigPingyin Trim(txtPingyin.Text)
 End If
 
End Sub

Private Sub txtPingyin_LostFocus()

 If AddIt = True Then Exit Sub
 '检测编码是否正确
 If Trim(txtPingyin) = "" Then Exit Sub
 GetItem "Pingyin"
 
End Sub

Private Sub txtSl_Change()

   If Trim(cmbCode.Text) <> "" And sSite <> "" And Val(txtSL) <> 0 Then
      cmdAdd.Enabled = True
    Else
      cmdAdd.Enabled = False
   End If
   
End Sub

Private Sub ConfigType()

   On Error GoTo Err_init
   Dim DB As Database
   Dim Ef As Recordset, sEXE As String
   Set DB = OpenDatabase(ConData, False, False, Constr)
   ' SQL语言删除
     sEXE = "Select Class From MenuType"
   Set Ef = DB.OpenRecordset(sEXE, dbOpenDynaset)
     If Ef.EOF And Ef.BOF Then
        Strip1.SelectedItem.Key = "Null"
        sGlobalType = ""
      Else
        Ef.MoveFirst
        Dim X As Integer
           X = 1
        Do While Not Ef.EOF
           Strip1.Tabs.Add X, Ef.Fields(0), Ef.Fields(0) & "&" & Chr(64 + X)
           X = X + 1
           Ef.MoveNext
        Loop
        sGlobalType = Strip1.SelectedItem.Key
     End If
     Ef.Close
     DB.Close
     Exit Sub
     
Err_init:
    MsgBox "菜单类型错误，不能为数字 ？ " & Err.Description, vbExclamation, "错误：By Yusilong."

End Sub

Private Sub Strip1_Click()
  
  '选择类别
  sGlobalType = Strip1.SelectedItem.Key
  If sGlobalType = "ALL" Then sGlobalType = ""
  ConfigGridX ""

End Sub

Private Sub AddItItem()

  '检测一些项目
   If Trim(cmbCode) = "" Then
      MsgBox "请输入物品编码，否则不能录入！   ", vbInformation
      cmbCode.SetFocus
      Exit Sub
   End If
   If Trim(txtPingyin) = "" Then
      MsgBox "请输入物品拼音码，否则不能录入！   ", vbInformation
      txtPingyin.SetFocus
      Exit Sub
   End If
   If Trim(txtName) = "" Then
      MsgBox "请输入物品名称，否则不能录入！   ", vbInformation
      txtName.SetFocus
      Exit Sub
   End If
   If Val(txtSL) = 0 Then
      MsgBox "请输入物品数量，否则不能录入！   ", vbInformation
      txtSL.SetFocus
      Exit Sub
   End If
   If Trim(txtDJ) = "" Then
      MsgBox "请输入物品单价，如果没有请输入0！  ", vbInformation
      txtDJ.SetFocus
      Exit Sub
   End If
   If Trim(txtJGF) = "" Then
      MsgBox "请输入物品加工费，如果没有请输入0！   ", vbInformation
      txtJGF.SetFocus
      Exit Sub
   End If
  '添加
  Dim DB As Database
  Dim Ef As Recordset
  Dim sTmp As String
  DBEngine.BeginTrans   '事务开始
  '-------------------------------------------
  Set DB = OpenDatabase(ConData, 0, 0, Constr)
  Set Ef = DB.OpenRecordset("Select * From tmpTodayCust", dbOpenDynaset)
      sTmp = "CID='" & Trim(cmbCode) & "'"
      Ef.AddNew
      Ef.Fields("Site") = sSite
      Ef.Fields("Name") = Trim(txtName)
      Ef.Fields("CID") = Trim(cmbCode)
      Ef.Fields("Pingyin") = Trim(txtPingyin)
      Ef.Fields("Unit") = Trim(txtUnit)
      Ef.Fields("Price") = CCur(txtDJ)
      Ef.Fields("Quanty") = -Val(txtSL)
      Ef.Fields("JGF") = CCur(txtJGF)
      Ef.Fields("Amo") = Round(Ef.Fields("Quanty") * Ef.Fields("Price"), 0) '不包括加工费 ,以后直接打折
      Ef.Fields("Amos") = Round(Ef.Fields("JGF") + Ef.Fields("Amo"))  '合计金额=加工费+总额
      Ef.Fields("DType") = sDType     '单类型
      Ef.Fields("DNumber") = sDNumber '单号
      Ef.Fields("Date") = Date
      Ef.Update
  Ef.Close
  DB.Close                 '事务结束
  '---------------------------------------------
  DBEngine.CommitTrans
  
  RefreshIt   '刷新菜单列表
  cmbCode.Text = "": txtName = "": txtPingyin = ""
  txtSL = "": txtUnit = "": txtDJ = 0: txtJGF = 0
  txtType = ""
  If AddIt = False Then cmbCode.SetFocus
  AddIt = False
  
End Sub

Private Sub RefreshIt()

   ConfigGrid1 sSite
 
End Sub

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

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

Private Sub GetItem(sType As String)

  On Error Resume Next
  Dim DB As Database
  Dim Ef As Recordset
  Set DB = OpenDatabase(ConData, 0, 0, Constr)
  Select Case sType
    Case "ID"
       Set Ef = DB.OpenRecordset("Select * From EatList Where 代码='" & Trim(cmbCode) & "'", dbOpenDynaset)
       If Ef.BOF And Ef.EOF Then '没有该记录时
          MsgBox "请输入正确的菜单编码！   ", vbExclamation
          cmbCode.Text = ""
          cmbCode.SetFocus
        Else
         '给出各个项的值
          txtPingyin = Ef.Fields("Pingyin")
          txtName = Ef.Fields("名称")
          txtSL = 1
          txtDJ = Ef.Fields("单价")
          txtUnit = Ef.Fields("单位")
          txtType = Ef.Fields("MenuType")
          'txtSL.SetFocus '修改数量
       End If
    Case Else
         Set Ef = DB.OpenRecordset("Select * From EatList Where Pingyin='" & Trim(txtPingyin) & "'", dbOpenDynaset)
       If Ef.BOF And Ef.EOF Then '没有该记录时
          Ef.Close
          DB.Close
          MsgBox "请输入正确的拼音码！   ", vbExclamation
          txtPingyin.Text = ""
          txtPingyin.SetFocus
        Else
         '给出各个项的值
          cmbCode = Ef.Fields("代码")
          txtName = Ef.Fields("名称")
          txtSL = 1
          txtDJ = Ef.Fields("单价")
          txtUnit = Ef.Fields("单位")
          txtType = Ef.Fields("MenuType")
          'txtSL.SetFocus '修改数量
       End If
    
  End Select
  
 Ef.Close
 DB.Close
 
End Sub

Private Sub ConfigPingyin(sCode As String)

On Error GoTo Err_init
Grid1X.Visible = False
Grid1X.Clear
Grid1X.Cols = 7
Grid1X.FormatString = "^ .. |^ 编码 |^ 拼音 |^ 菜名 |^ 单价 |^ 单位 |^ 类型"
Grid1X.ColWidth(0) = 300
Grid1X.ColWidth(1) = 1200
Grid1X.ColWidth(2) = 1200
Grid1X.ColWidth(3) = 1200
Grid1X.ColWidth(4) = 1000
Grid1X.ColWidth(5) = 600
Grid1X.ColWidth(6) = 1000

Dim sSQL As String
   
  If sGlobalType = "" Then
    If sCode <> "" Then
       sSQL = "Select * From EatList Where (Pingyin Like '" & sCode & "*') Order By Pingyin"
    Else
       sSQL = "Select * From EatList Order By Pingyin"
    End If
  Else
    If sCode <> "" Then
       sSQL = "Select * From EatList Where (Pingyin Like '" & sCode & "*' And MenuType='" & sGlobalType & "') Order By Pingyin"
    Else
       sSQL = "Select * From EatList Where MenuType='" & sGlobalType & "' Order By Pingyin"
    End If
  End If
    
Dim DB As Database, Ef As Recordset, HH As Integer, DelNO As Long
Dim shiftStr As String, shiftStrL As String, shiftStrR As String, shiftNum As Integer, ili As Integer, tempStr As String, SureStr As String, Qy As Integer
    Set DB = OpenDatabase(ConData, False, False, Constr)
    
    Set Ef = DB.OpenRecordset(sSQL, dbOpenDynaset)
        
     If Ef.EOF And Ef.BOF Then
        DelNO = 0
      Else
        Do While Not Ef.EOF
           DelNO = DelNO + 1
           Ef.MoveNext
        Loop
     End If
        Grid1X.Rows = DelNO + 1
        
        If Grid1X.Rows < 28 Then
           Grid1X.Rows = 28
        End If
        
     If DelNO > 0 Then
        Ef.MoveFirst  '返回第一
        HH = 1
        Do While Not Ef.EOF()
           Grid1X.Row = HH
           Grid1X.Col = 0
           Grid1X.CellAlignment = 4
        If Not IsNull(Ef.Fields("ID").Value) Then
           Grid1X.Text = Ef.Fields("ID").Value
        End If
           Grid1X.Row = HH
           Grid1X.Col = 1
           Grid1X.CellAlignment = 1
        If Not IsNull(Ef.Fields("代码").Value) Then
           Grid1X.Text = Ef.Fields("代码").Value
        End If
           Grid1X.Row = HH
           Grid1X.Col = 2
           Grid1X.CellAlignment = 1
        If Not IsNull(Ef.Fields("Pingyin").Value) Then
           Grid1X.Text = Ef.Fields("Pingyin").Value
        End If
           Grid1X.Row = HH
           Grid1X.Col = 3
           Grid1X.CellAlignment = 1
        If Not IsNull(Ef.Fields("名称").Value) Then
           Grid1X.Text = Ef.Fields("名称").Value
        End If
           Grid1X.Row = HH
           Grid1X.Col = 4
           Grid1X.CellAlignment = 1
        If Not IsNull(Ef.Fields("单价").Value) Then
           Grid1X.Text = Ef.Fields("单价").Value
        End If
           Grid1X.Row = HH
           Grid1X.Col = 5
           Grid1X.CellAlignment = 1
        If Not IsNull(Ef.Fields("单位").Value) Then
           Grid1X.Text = Ef.Fields("单位").Value
        End If
           Grid1X.Row = HH
           Grid1X.Col = 6
           Grid1X.CellAlignment = 1
        If Not IsNull(Ef.Fields("MenuType").Value) Then
           Grid1X.Text = Ef.Fields("MenuType").Value
        End If
        
          Ef.MoveNext
          HH = HH + 1
        Loop
        Ef.Close
        DB.Close
    End If
 Grid1X.Col = 1
 Grid1X.Row = 1
 Grid1X.ColSel = 6
 Grid1X.Visible = True
   Exit Sub
Err_init:
 MsgBox "网络配置错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub SaveIt(sType As String)

 Dim DB As Database
 Dim sTmp As String
 Dim cDCJE As Currency, cDCJGF '点菜金额
 
'保存退单记录
 DBEngine.BeginTrans
 Set DB = OpenDatabase(ConData, 0, 0, Constr)
     sTmp = "Insert Into TodayCust Select * From tmpTodayCust"
     DB.Execute sTmp
     sTmp = "Delete * From tmpTodayCust"
     DB.Execute sTmp
     DB.Close
 DBEngine.CommitTrans
     
End Sub

Private Sub txtSL_LostFocus()
 If txtSL.Text = "" Then
    txtSL = 1
    Exit Sub
 End If
 If Val(txtSL.Text) = "0" Then
   txtSL = 1
   Exit Sub
 End If
 
End Sub