frmdc.frm

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

    txtUnit = ""
    txtType = ""
    txtJGF = 0
    Exit Sub
 End If
 If SearchAgain = False Then GetItem "Pingyin"
 
End Sub

Private Sub txtSl_Change()

   If txtSL.Text = "" Then
      txtSL.Text = "0"
      txtSL.SelStart = 0
      txtSL.SelLength = 1
   End If
   
   If txtSL.Text = "." Then
      txtSL.Text = "0."
      txtSL.SelStart = 2
      txtSL.SelLength = 0
   End If
   
   If Trim(cmbCode.Text) <> "" And sPubSite <> "" And Val(txtSL) <> 0 And Val(txtDJ.Text) <> 0 Then
      cmdAdd.Enabled = True
    Else
      cmdAdd.Enabled = False
   End If
   
End Sub

Private Sub ConfigType()

   On Error GoTo Err_init
   
   Dim tDB As Connection
   Dim tEf As Recordset, sEXE As String
   Set tDB = CreateObject("ADODB.Connection")
       tDB.Open Constr
       sEXE = "Select Class From MenuType"
   Set tEf = CreateObject("ADODB.Recordset")
       tEf.Open sEXE, tDB, adOpenStatic, adLockReadOnly, adCmdText
     If tEf.EOF And tEf.BOF Then
        Strip1.SelectedItem.Key = "Null"
        sGlobalType = ""
      Else
        Dim x As Integer
            x = 1
        Do While Not tEf.EOF
          '给出菜分类
           Strip1.Tabs.Add x, tEf.Fields(0), tEf.Fields(0) & "&" & Chr(64 + x)
           x = x + 1
           tEf.MoveNext
        Loop
        sGlobalType = Strip1.SelectedItem.Key
     End If
     tEf.Close
     Set tEf = Nothing
     tDB.Close
     Set tDB = Nothing
     Exit Sub
     
Err_init:
    MsgBox "菜分类错误，名称不能全为数字 ？ " & Err.Description, vbExclamation, "错误：0577-86261392 013955647557"

End Sub

Private Sub InsertToMenu(tmpView As ListView, sText1 As String, sText2 As String, sText3 As String _
      , sText4 As String, sText5 As String, sText6 As String)
 
   On Error Resume Next
   
   If Trim(sText1) = "" Then Exit Sub
   
   Dim lstTmp As ListItem
   Set lstTmp = tmpView.ListItems.Add
       lstTmp.Text = Trim(sText1)
       lstTmp.SubItems(1) = Trim(sText2)
       lstTmp.SubItems(2) = Trim(sText3)
       lstTmp.SubItems(3) = Trim(sText4)
       lstTmp.SubItems(4) = Trim(sText5)
       lstTmp.SubItems(5) = Trim(sText6)
End Sub

Private Sub InsertToCust(tmpView As ListView, sText1 As String, sText2 As String, sText3 As String _
      , sText4 As String, sText5 As String, sText6 As String, sText7 As String, sText8 As String, sText9 As String)
 
   On Error Resume Next
   
   Dim lstTmp As ListItem
   Set lstTmp = tmpView.ListItems.Add
       lstTmp.Text = Trim(sText1)
       lstTmp.SubItems(1) = Trim(sText2)
       lstTmp.SubItems(2) = Trim(sText3)
       lstTmp.SubItems(3) = Trim(sText4)
       lstTmp.SubItems(4) = Trim(sText5)
       lstTmp.SubItems(5) = Format(Trim(sText6), "0.00")
       lstTmp.SubItems(6) = Format(Trim(sText7), "0.00")
       lstTmp.SubItems(7) = Format(Trim(sText8), "0.00")
       lstTmp.SubItems(8) = Trim(sText9)
       
End Sub

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

Private Sub AddItItem()

   On Error GoTo AddERR
   
  '检测一些项目
   If Trim(cmbCode.Text) = "" Then
      MsgBox "请输入物品编码，否则不能录入！   ", vbInformation
      cmbCode.SetFocus
      Exit Sub
   End If
   If Trim(txtPingyin.Text) = "" Then
      MsgBox "请输入物品拼音码，否则不能录入！   ", vbInformation
      txtPingyin.SetFocus
      Exit Sub
   End If
   If Trim(txtName.Text) = "" Then
      MsgBox "请输入物品名称，否则不能录入！   ", vbInformation
      txtName.SetFocus
      Exit Sub
   End If
   If Val(txtSL) = 0 Or IsNumeric(txtSL.Text) = False Then
      MsgBox "请输入物品数量，否则不能录入！   ", vbInformation
      txtSL.SetFocus
      Exit Sub
   End If
   If Trim(txtDJ) = "" Or IsNumeric(txtDJ.Text) = False Then
      MsgBox "请输入物品单价，如果没有请输入0！  ", vbInformation
      txtDJ.SetFocus
      Exit Sub
   End If
   If Trim(txtJGF) = "" Or IsNumeric(txtJGF.Text) = False Then
      MsgBox "请输入物品加工费，如果没有请输入0！   ", vbInformation
      txtJGF.SetFocus
      Exit Sub
   End If
   If Trim(txtType) = "" Then
      MsgBox "请输入物品所属类别！   ", vbInformation
      txtType.SetFocus
      Exit Sub
   End If
  '添加到消费库中 ============================================================
   Dim DB As Connection
   Dim EF As Recordset, FB As Recordset
   Dim sTMp As String
   
   Set DB = CreateObject("ADODB.COnnection")
       DB.Open Constr
       DB.BeginTrans
   Set EF = CreateObject("ADODB.Recordset")
   Set FB = CreateObject("ADODB.Recordset")
   
      If Val(txtSL.Text) < 0 Then '退单时
        '检测是否有足够的数量退单++++++++++++++++++++++++++++++++++++++
         Dim tmpSql As String
         Dim bTui As Boolean   '可以退时
             tmpSql = "Select Sum(Quanty) From tmpCust where site='" & sPubSite & "' And Name='" & Trim(txtName.Text) & "' And " _
                    & " CID='" & Trim(cmbCode) & "' And DType='" & sPubType & "'"
             EF.Open tmpSql, DB, adOpenStatic, adLockReadOnly, adCmdText
            '如果没有找到该菜单时,BTui标记为假
             If EF.BOF And EF.EOF Then  '没有记录时
                bTui = False
              Else
                If IsNull(EF.Fields(0)) = True Then
                   bTui = False
                Else
                 '数量是否足够
                  If Abs(Val(txtSL)) > EF.Fields(0) Then
                     bTui = False
                    Else
                     bTui = True   '可以退单
                  End If
                End If
             End If
            If bTui = False Then
              '退出
               EF.Close
               Set EF = Nothing
               DB.RollbackTrans
               DB.Close
               Set DB = Nothing
               MsgBox "很抱歉：请检查菜单上是否有该菜 ？   " & vbCrLf & vbCrLf & "或者数量够不够退？ ", vbExclamation
               txtSL.SetFocus
               Exit Sub
            End If
            EF.Close
      End If
      Dim DCID As Long
      DCID = GetFixNo("点菜明细号")
     '打开消费记录表=================================================================
      EF.Open "Select * From tmpCust", DB, adOpenStatic, adLockOptimistic, adCmdText
      EF.AddNew
      EF.Fields("ID") = DCID
      EF.Fields("Site") = sPubSite
      EF.Fields("Name") = Trim(txtName.Text)
      EF.Fields("CID") = Trim(cmbCode.Text)
      EF.Fields("Pingyin") = Trim(txtPingyin.Text)
      EF.Fields("Unit") = Trim(txtUnit.Text)
      EF.Fields("Price") = txtDJ.Text
      EF.Fields("Quanty") = Val(txtSL)
      EF.Fields("JGF") = txtJGF.Text
      EF.Fields("Amo") = Round(EF.Fields("Quanty") * EF.Fields("Price"), 0) '不包括加工费 ,以后直接打折
      EF.Fields("Amos") = Round(EF.Fields("JGF") + EF.Fields("Amo"), 0)     '合计金额=加工费+总额
      EF.Fields("DType") = Trim(txtType.Text)                               '单类型
      EF.Update
      EF.Close
     '添加飞单机中==================================================================
      FB.Open "Select * from ptCust", DB, adOpenStatic, adLockOptimistic, adCmdText
      FB.AddNew
      FB.Fields("ID") = DCID
      FB.Fields("Site") = sPubSite
      FB.Fields("Name") = Trim(txtName.Text)
      FB.Fields("CID") = Trim(cmbCode.Text)
      FB.Fields("Pingyin") = Trim(txtPingyin.Text)
      FB.Fields("Unit") = Trim(txtUnit.Text)
      FB.Fields("Price") = txtDJ.Text
      FB.Fields("Quanty") = Val(txtSL)
      FB.Fields("JGF") = txtJGF.Text
      FB.Fields("Amo") = Round(FB.Fields("Quanty") * FB.Fields("Price"), 0) '不包括加工费 ,以后直接打折
      FB.Fields("Amos") = Round(FB.Fields("JGF") + FB.Fields("Amo"), 0)     '合计金额=加工费+总额
      FB.Fields("DType") = Trim(txtType.Text)                               '单类型
      FB.Fields("AtTime") = Time
      FB.Fields("DOper") = UserText
      FB.Update
      FB.Close
     '===============================================================================
      DB.CommitTrans
      DB.Close                 '事务结束
      Set EF = Nothing
      Set FB = Nothing
      Set DB = Nothing
  
      RefreshIt   '刷新菜单列表
      
      cmbCode.Text = "": txtName.Text = "": txtPingyin = ""
      txtSL = "1": txtUnit = "": txtDJ = "0": txtJGF = "0"
      txtType = ""
  
      If AddIt = False Then cmbCode.SetFocus
         AddIt = False
     
   Exit Sub
AddERR:
   MsgBox "添加菜单错误:" & Err.Description, vbCritical
   
End Sub

Private Sub RefreshIt()

   ConfigGrid1 sPubSite
 
End Sub

'检测所输入的菜谱是否存在。
Private Sub GetItem(sType As String)

  On Error GoTo GetERR
  
 '该编号已经唯一时
  If lstPro.ListItems.Count >= 1 Then
     '无需查询，直接给出该菜单参数
      AddIt = True
      cmbCode.Text = lstPro.SelectedItem.Text
      txtPingyin = lstPro.SelectedItem.SubItems(2)
      txtName = lstPro.SelectedItem.SubItems(1)
      txtSL = 1
      txtDJ = lstPro.SelectedItem.SubItems(3)
      txtUnit = lstPro.SelectedItem.SubItems(4)
      txtType = lstPro.SelectedItem.SubItems(5)
      txtJGF = 0
      AddIt = False
      SearchAgain = True
      Exit Sub
  End If
  
  Dim DB As Connection
  Dim EF As Recordset
  Set DB = CreateObject("ADODB.Connection")
      DB.Open Constr
  Select Case sType
    Case "MID"
       Set EF = CreateObject("ADODB.Recordset")
           EF.Open "Select * From EatList Where MID='" & Trim(cmbCode.Text) & "'", DB, adOpenStatic, adLockReadOnly
        If EF.BOF And EF.EOF Then '没有该记录时
           EF.Close
           Set EF = Nothing
           DB.Close
           Set DB = Nothing
           MsgBox "请输入正确的菜单编码！   ", vbExclamation
           cmbCode.Text = ""
           txtPingyin.Text = "": txtName.Text = "": txtSL.Text = "0"
           txtDJ.Text = "0": txtUnit.Text = "": txtType.Text = ""
           cmbCode.SetFocus
        Else
          '给出各个项的值
           txtPingyin = EF.Fields("Pingyin")
           txtName = EF.Fields("MName")
           txtSL = 1
           txtDJ = EF.Fields("MPrice")
           txtUnit = NullValue(EF.Fields("MUnit"))
           txtType = NullValue(EF.Fields("MType"))
           SearchAgain = True
           EF.Close
           Set EF = Nothing
           DB.Close
           Set DB = Nothing
       End If
    Case Else
        Set EF = CreateObject("ADODB.Recordset")
            EF.Open "Select * From EatList Where Pingyin='" & Trim(txtPingyin) & "'", DB, adOpenStatic, adLockReadOnly
         If EF.BOF And EF.EOF Then '没有该记录时
            EF.Close
            Set EF = Nothing
            DB.Close
            Set DB = Nothing
            MsgBox "请输入正确的拼音码！   ", vbExclamation
            txtPingyin.Text = ""
            txtPingyin.SetFocus
          Else
           '给出各个项的值
            cmbCode = EF.Fields("MID")
            txtName = EF.Fields("MName")
            txtSL = 1
            txtDJ = EF.Fields("MPrice")
            txtUnit = NullValue(EF.Fields("MUnit"))
            txtType = NullValue(EF.Fields("MType"))
            SearchAgain = True
            EF.Close
            Set EF = Nothing
            DB.Close
            Set DB = Nothing
       End If
  End Select
  
  Exit Sub
GetERR:
  MsgBox "给出Item错误:" & Err.Description, vbCritical
  
End Sub

Private Sub ConfigPingyin(sCode As String)

    On Error GoTo Err_init
    
    sCode = Trim(sCode)
    If sCode = "" And sGlobalType = "" Then Exit Sub
    
    Dim sSQL As String
    If sGlobalType = "" Then
         If sCode <> "" Then
             sSQL = "Select * From EatList Where (PingYin Like '" & sCode & "%') Order By PingYin"
         Else
             Exit Sub
         End If
      Else
         If sCode <> "" Then
            sSQL = "Select * From EatList Where (PingYin Like '" & sCode & "%' And MType='" & sGlobalType & "') Order By PingYin"
         Else
            sSQL = "Select * From EatList Where MType='" & sGlobalType & "' Order By PingYin"
         End If
    End If
        
    Dim DB As Connection, EF As Recordset
    Set DB = CreateObject("ADODB.Connection")
        DB.Open Constr
    Set EF = CreateObject("ADODB.Recordset")
        
        EF.Open sSQL, DB, adOpenStatic, adLockReadOnly, adCmdText
      
      lstPro.Visible = False
      lstPro.ListItems.Clear
      
        If Not (EF.EOF And EF.BOF) Then
            Do While Not EF.EOF()
               InsertToMenu lstPro, EF("MID"), EF("MName"), NullValue(EF("PingYin")), EF("MPrice"), NullValue(EF("Munit")), EF("MType")
               EF.MoveNext
            Loop
        End If
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
        lstPro.Visible = True
        
   Exit Sub
Err_init:
   MsgBox "给出菜单错误:" & Err.Description, vbCritical
 
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

Private Sub InsertToMenuList(tmpView As ListView, sText1 As String, sText2 As String, sText3 As String _
      , sText4 As String, sText5 As String, sText6 As String, sText7 As String)
 
   On Error Resume Next
   
   If Trim(sText1) = "" Then Exit Sub
   
   Dim lstTmp As ListItem
   Set lstTmp = tmpView.ListItems.Add
       lstTmp.Text = sText1
       lstTmp.SubItems(1) = sText2
       lstTmp.SubItems(2) = sText3
       lstTmp.SubItems(3) = Format(sText4, "0.00")
       lstTmp.SubItems(4) = Format(sText5, "0.00")
       lstTmp.SubItems(5) = Format(sText6, "0.00")
       lstTmp.SubItems(6) = sText7
       
End Sub