frmboxdc.frm

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

          CDB.Open Constr
      Set cRS = CreateObject("ADODB.Recordset")
          sTMp = "Select EatList.MID,EatList.MName,EatList.MUnit,EatList.MType,EatList.MPrice,EatList.Pingyin," _
               & "tbdMenuCatDetail.MenuID,tbdMenuCatDetail.MenuNum from " _
               & " EatList Inner Join tbdMenuCatDetail On EatList.MID=tbdMenuCatDetail.MenuName " _
               & " Where tbdMenuCatDetail.MenuID='" & sMenuID & "'"
          cRS.Open sTMp, CDB, adOpenStatic, adLockReadOnly, adCmdText
         '该酒席有菜单时
          If Not (cRS.EOF And cRS.BOF) Then
               '双击将该值送给详细项目
                Do While Not cRS.EOF
                     AddIt = True
                     cmbCode.Text = cRS("MID")
                     txtPingyin = cRS("Pingyin")
                     txtName = cRS("MName")
                     txtSL = cRS("MenuNum")
                     txtDJ = 0
                     txtUnit = NullValue(cRS("MUnit"))
                     txtType = NullValue(cRS("MType"))
                     txtJGF = 0
                     If cmdAdd.Enabled = True Then cmdAdd.Value = True  '自动增加到列表中
                        AddIt = False
                    '添加下一产品
                     cRS.MoveNext
                Loop
          End If
          cRS.Close
          CDB.Close
      Set cRS = Nothing
      Set CDB = Nothing
  End If
  
  RefreshIt
  MsgBox "酒席添加完毕！  ", vbInformation
  
End Sub

Private Sub Form_Activate()

  Strip1.Enabled = True

End Sub

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

 Select Case KeyCode
 
  Case 120  'F9
    If cmdAdd.Enabled = True Then cmdAdd.Value = True
  Case 121  'F10
    If cmdDel.Enabled = True Then cmdDel.Value = True
  Case 122  'F11
    If cmdClose.Enabled = True Then cmdClose.Value = True
  Case Else
    '...
    
End Select
  
End Sub

Private Sub Form_Load()

 GetFormSet Me, Screen
 Me.Caption = Me.Caption + "餐桌【" & sBoxSite & "】"
 AddIt = False
 sGlobalType = ""
'配置菜单类型
 ConfigType
 ConfigGridX ""
 ConfigGrid1 sBoxSite  '给出当前座位菜单列表

End Sub

Private Sub ConfigGridX(sCode As String)

   On Error GoTo Err_init

    Dim sSQL As String

    Dim DB As Connection, EF As Recordset
    Set DB = CreateObject("ADODB.Connection")
        DB.Open Constr
    Set EF = CreateObject("ADODB.Recordset")
        
      If sGlobalType = "" Then
         If sCode <> "" Then
             sSQL = "Select * From EatList Where (MID Like '" & sCode & "%') Order By MID"
         Else
             sSQL = "Select * From EatList Order By MID"
         End If
      Else
         If sCode <> "" Then
            sSQL = "Select * From EatList Where (MID Like '" & sCode & "%' And MType='" & sGlobalType & "') Order By MID"
         Else
            sSQL = "Select * From EatList Where MType='" & sGlobalType & "' Order By MID"
         End If
      End If
        
      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 Form_Resize()

 On Error Resume Next
 
 If Me.WindowState = 1 Then Exit Sub
    Strip1.Width = Frame3.Width
 
End Sub

Private Sub Form_Unload(Cancel As Integer)

  SaveFormSet Me
  '保存单据实质
  '-----------------------------------------------------------------
  'SaveIt sPubType
  
End Sub

Private Sub cmbCode_Change()
   
  If Trim(cmbCode.Text) <> "" And sBoxSite <> "" And Val(txtSL) <> 0 Then
      cmdAdd.Enabled = True
    Else
      cmdAdd.Enabled = False
   End If
 
   SearchAgain = False
 
  If AddIt = False Then
    sGlobalType = ""
   'Strip1.Tabs.Item("ALL").Selected = True
    If Trim(cmbCode.Text) <> "" Then
       ConfigGridX Trim(cmbCode.Text)
    End If
 End If
   
End Sub

Public Sub ConfigGrid1(sCod As String)

    On Error GoTo Err_init

    Dim sSQL As String
   '当前座位,当前菜单中内容
    sSQL = "Select * From tmpBox Where Site='" & sBoxSite & "'"
        
    Me.MousePointer = 11
    lstCust.ListItems.Clear
    
    Dim DB As Connection, EF As Recordset
    Dim curJGF As Currency, curQuanty As Currency, curAmos As Currency
        curJGF = 0: curQuanty = 0: curAmos = 0
        
    Set DB = CreateObject("ADODB.Connection")
    Set EF = CreateObject("ADODB.Recordset")
        DB.Open Constr
        EF.Open sSQL, DB, adOpenStatic, adLockReadOnly, adCmdText
        If Not (EF.EOF And EF.BOF) Then
                Do While Not EF.EOF()
                   curJGF = curJGF + EF("JGF")
                   curQuanty = curQuanty + EF("Quanty")
                   curAmos = curAmos + EF("AMOS")
                   InsertToCust lstCust, EF("ID"), EF("CID"), EF("Name"), NullValue(EF("Unit")), _
                     EF("Price"), EF("Quanty"), EF("JGF"), EF("AMOS"), EF("Site")
                  EF.MoveNext
                Loop
               '插入合计
                InsertToCust lstCust, " ", " ", "【 合 计 】 ", " ", Chr(10), Trim(CStr(curQuanty)), Trim(CStr(curJGF)), Trim(CStr(curAmos)), " "
                cmdDel.Enabled = True
             Else
                cmdDel.Enabled = False
        End If
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
        Me.MousePointer = 0
   
        Exit Sub
Err_init:
    Me.MousePointer = 0
    MsgBox "给出餐桌的 " & sGlobalType & " 单据错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub


Private Sub lstCust_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

 On Error Resume Next
 
'排序操作
 If lstCust.ListItems.Count > 0 Then
 
    lstCust.SortKey = ColumnHeader.Index - 1
    lstCust.Sorted = True
    
    If lstCust.SortOrder = lvwAscending Then
       lstCust.SortOrder = lvwDescending
       Else
       lstCust.SortOrder = lvwAscending
    End If
    
 End If


End Sub

Private Sub lstCust_ItemClick(ByVal Item As MSComctlLib.ListItem)

  If lstCust.ListItems.Count > 0 Then
     If lstCust.SelectedItem.Text <> "" Then
        cmdDel.Enabled = True
       Else
        cmdDel.Enabled = False
     End If
   Else
    cmdDel.Enabled = False
  End If
  
  
End Sub

Private Sub lstPro_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
 
 On Error Resume Next
 
'排序操作
 If lstPro.ListItems.Count > 0 Then
 
    lstPro.SortKey = ColumnHeader.Index - 1
    lstPro.Sorted = True
    
    If lstPro.SortOrder = lvwAscending Then
       lstPro.SortOrder = lvwDescending
       Else
       lstPro.SortOrder = lvwAscending
    End If
    
 End If

End Sub

Private Sub lstPro_DblClick()

  If lstPro.ListItems.Count = 0 Then Exit Sub
  If lstPro.SelectedItem.Text = "" Then Exit Sub

  '双击将该值送给详细项目
   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
   
   If cmdAdd.Enabled = True Then cmdAdd.Value = True  '自动增加到列表中
      AddIt = False

End Sub

Private Sub lstPro_ItemClick(ByVal Item As MSComctlLib.ListItem)

  If lstPro.ListItems.Count = 0 Then Exit Sub
  If lstPro.SelectedItem.Text = "" Then Exit Sub
  
  '双击将该值送给详细项目
   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
    
End Sub

Private Sub lstPro_KeyPress(KeyAscii As Integer)
  
  If KeyAscii = 13 Then
    '回车时
     Call lstPro_DblClick
  End If

End Sub

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

End Sub

Private Sub txtJGF_Change()

   If txtJGF.Text = "" Then
      txtJGF.Text = "0"
      txtJGF.SelStart = 0
      txtJGF.SelLength = 1
   End If
   
   If txtJGF.Text = "." Then
      txtJGF.Text = "0."
      txtJGF.SelStart = 2
      txtJGF.SelLength = 0
   End If
  
End Sub


Private Sub txtPingyin_Change()
 
 SearchAgain = False
 
 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
 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