frmdc.frm

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

          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
  cmbCode.SetFocus
  
End Sub

Private Sub Form_Activate()
  
  On Error Resume Next
  Strip1.Enabled = True
  
 '如果已经确定服务员时，直接跳到菜单编号即可
  If cmbWaiter.Text <> "" Then
     cmbCode.SetFocus
  End If
  
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 123  'F12
    If cmdIntegration.Enabled = True Then cmdIntegration.Value = True
  Case Else
    '...
    
End Select
  
End Sub

Private Sub Form_Load()

 GetFormSet Me, Screen
 Me.Caption = Me.Caption + "餐桌【" & sPubSite & "】"
 AddIt = False
 sGlobalType = ""
 sTmpWaiter = ""
'列出服务员姓名
 GetEmployList cmbWaiter
'给出服务员
 Dim sWaiter As String
     sWaiter = GetWaiter(sPubSite)
  cmbWaiter.Text = sWaiter
'配置菜单类型
 ConfigType
 ConfigGridX ""
 ConfigGrid1 sPubSite  '给出当前座位菜单列表

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)

  On Error Resume Next
  SaveFormSet Me
  sTmpWaiter = Trim(cmbWaiter.Text)
  
End Sub

Private Sub cmbCode_Change()
   
  If Trim(cmbCode.Text) <> "" And sPubSite <> "" And Val(txtSL) <> 0 Then
      cmdAdd.Enabled = True
    Else
      cmdAdd.Enabled = False
   End If
 
  '每次修改之后，都必须重新搜索。
   SearchAgain = False
  
  'Addit等于用户单击左边的列表时
  If AddIt = False Then
     sGlobalType = ""
    '否则用户输入时，检测该菜单编码列表
     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 tmpCust Where Site='" & sPubSite & "'"
        
    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 "给出餐桌的 " & sPubType & " 单据错误!    " & 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 sPubSite <> "" 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 = ""
   '通过拼音来查找
    ConfigPingyin Trim(txtPingyin.Text)
 End If
 
End Sub

Private Sub txtPingyin_KeyDown(KeyCode As Integer, Shift As Integer)
   
   On Error GoTo Errorx
   
  '给出F2-F8的所有内容,缺省显示第一道菜
     Dim lMenu As Integer
   Select Case KeyCode
     Case 113        'F2
       lMenu = 2
     Case 114        'F3
       lMenu = 3
     Case 115        'F4
       lMenu = 4
     Case 116        'F5
       lMenu = 5
     Case 117        'F6
       lMenu = 6
     Case 118        'F7
       lMenu = 7
     Case 119        'F8
       lMenu = 8
     Case Else
       Exit Sub
   End Select
   
   If lstPro.ListItems.Count > 0 Then
     '索行超过时退出。
      If lMenu > lstPro.ListItems.Count Then Exit Sub
     '无需查询，直接给出该菜单参数
      AddIt = True
     '选择该行
      lstPro.ListItems(lMenu).Selected = 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
      txtSL.SetFocus
      Exit Sub
   End If
   
   Exit Sub
Errorx:
   MsgBox "给出列表菜单错误:" & Err.Description, vbCritical

End Sub

Private Sub txtPingyin_LostFocus()

 If AddIt = True Then Exit Sub
 '检测编码是否正确
 If Trim(txtPingyin) = "" Then
    cmbCode.Text = ""
    txtName = ""
    txtSL = 1
    txtDJ = 0