frmboxform.frm

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

    lstPro.Height = Frame1.Height - 530
    lstPRE.Height = lstPro.Height
    lstPro.Width = Frame1.Width - 150 - lstPRE.Width
    Frame2.Width = Frame1.Width
    cmdCancel.Left = Me.ScaleWidth - cmdCancel.Width - 300
     
End Sub

Private Sub Form_Unload(Cancel As Integer)

 Timer1.Interval = 0
 SaveFormSet Me
 frmMain.lbControl.Caption = "收银控制中心"
 
End Sub

Private Sub ConfigGrid()

   On Error GoTo Err_init

   Dim sSQL As String
   Dim cHJ As Currency, cJGF As Currency, cQuanty As Currency
   
    IsRunning = True
    cHJ = 0: cJGF = 0: cQuanty = 0
      
    If sCustType = "ALL" Then sCustType = ""
    If Trim(sCustType) <> "" Then
        sSQL = "Select * From tmpCust Where DType='" & Trim(sCustType) & "' And Site='" & sBoxSite & "'"
      Else
         sSQL = "Select * From tmpCust Where Site='" & sBoxSite & "'"
    End If
   
    Dim DB As Connection, EF As Recordset
   
    lstPro.ListItems.Clear
    
    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()
               InsertToMenuList lstPro, EF.Fields("ID"), EF.Fields("CID"), EF.Fields("Name"), _
                   EF.Fields("Price"), EF.Fields("Quanty"), EF.Fields("JGF"), EF.Fields("Amos")
              '累计合计
               cHJ = cHJ + EF.Fields("Amos")
               cJGF = cJGF + EF.Fields("JGF")
               cQuanty = cQuanty + EF.Fields("Quanty")
               EF.MoveNext
            Loop
           '添加合计
            InsertToMenuList lstPro, "", "", "【 合 计 】 ", Chr(10), Trim(CStr(cQuanty)), Trim(CStr(cJGF)), Trim(CStr(cHJ))

        End If
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
        IsRunning = False
        
        Exit Sub
Err_init:
 IsRunning = False
 MsgBox "列出点菜内容错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

'预订菜单
Private Sub ConfigGridPre()

   On Error GoTo Err_init

   Dim sSQL As String
   Dim cHJ As Currency, cJGF As Currency, cQuanty As Currency
   
    IsRunning = True
    cHJ = 0: cJGF = 0: cQuanty = 0
      
    If sCustType = "ALL" Then sCustType = ""
    If Trim(sCustType) <> "" Then
        sSQL = "Select * From tmpBox Where DType='" & Trim(sCustType) & "' And Site='" & sBoxSite & "'"
      Else
         sSQL = "Select * From tmpBox Where Site='" & sBoxSite & "'"
    End If
   
    Dim DB As Connection, EF As Recordset
   
    lstPRE.ListItems.Clear
    
    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()
               InsertToPreList lstPRE, EF.Fields("ID"), EF.Fields("CID"), EF.Fields("Name"), _
                   EF.Fields("Quanty")
              '累计合计
               cHJ = cHJ + EF.Fields("Amos")
               cJGF = cJGF + EF.Fields("JGF")
               cQuanty = cQuanty + EF.Fields("Quanty")
               EF.MoveNext
            Loop
           '添加合计
            InsertToPreList lstPRE, "", "", "【 合 计 】 ", Trim(CStr(cQuanty))
        End If
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
        IsRunning = False
        
        Exit Sub
Err_init:
 IsRunning = False
 MsgBox "列出预点菜内容错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
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"
        sCustType = ""
      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
        sCustType = 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 Grid1_DblClick()

'  If Grid1.Text <> "" Then
'     If Trim(cmbSite.Text) = "" Then
'        MsgBox "对不起，请注明该物品的座位号！    ", vbInformation, "提示：By Yusilong."
'        cmbSite.SetFocus
'        Exit Sub
'     End If
'     frmQuantly.Show 1
'     If SureQuantly = True Then
'        Dim lCurRow As Long
'            lCurRow = Grid1.Row '当前行
'            AddRecord Grid1.TextMatrix(lCurRow, 1), "名称", Grid1.TextMatrix(lCurRow, 2), "单价", Grid1.TextMatrix(lCurRow, 3), "单位", Grid1.TextMatrix(lCurRow, 4), "代码", Grid1.TextMatrix(lCurRow, 5), "MenuType", Grid1.TextMatrix(lCurRow, 2) * sSL, "金额", "tmpSell"
'           ConfigGrid2 Trim(cmbSite.Text)
'     End If
'   Else
'     Exit Sub
'  End If
  
End Sub


Private Sub lstPRE_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

 '显示操作菜单
  If Button = 2 Then
     PopupMenu mnuSystem
  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 mnuClean_Click()

  Call cmdClean_Click
  
End Sub

Private Sub mnuDC_Click()

  Call cmdDC_Click
  
End Sub

Private Sub mnuLD_Click()

  Call cmdOK_Click
  
End Sub

Private Sub Strip1_Click()
  
  '选择类别
  sCustType = Strip1.SelectedItem.Key
  
 '选定已点酒菜
  ConfigGrid
 '选定未预点菜
  ConfigGridPre

End Sub

Private Sub ConfigSite()

   On Error GoTo Err_init
   Dim DB As Connection
   Dim EF As Recordset, sEXE As String
   
   Set DB = CreateObject("ADODB.Connection")
   Set EF = CreateObject("ADODB.Recordset")
      '不显示维修的桌号
       sEXE = "Select * From SiteType Where SiteStatus<>4"
       DB.Open Constr
       EF.Open sEXE, DB, adOpenStatic, adLockReadOnly, adCmdText
     If EF.EOF And EF.BOF Then
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
        Exit Sub
      Else
        cmbSite.Clear
        Do While Not EF.EOF
           cmbSite.AddItem EF.Fields("Class")
           EF.MoveNext
        Loop
     End If
     EF.Close
     Set EF = Nothing
     DB.Close
     Set DB = Nothing
     Exit Sub
     
Err_init:
    MsgBox "装载（座位）未知错误！" & Err.Description, vbExclamation, "错误：By Yusilong."

End Sub
Private Sub CopyIt(sFirstSite As String)

 On Error GoTo ERR_HZ
    Dim DB As Connection
    Dim EF As Recordset
    Dim lSheelID As Long
    Set DB = CreateObject("ADODB.Connection")
    Set EF = CreateObject("ADODB.Recordset")
        DB.Open Constr
        EF.Open "Select * From tmpSite Where Site='" & sFirstSite & "'", DB, adOpenStatic, adLockReadOnly, adCmdText
       '首先检测该座位有没有上台，退出
        If EF.BOF And EF.EOF Then  '没有记录时为0
           EF.Close
           Set EF = Nothing
           DB.Close
           Set DB = Nothing
           MsgBox "对不起，没有找到[" & sFirstSite & "]消费记录单！   " & vbCrLf & vbCrLf & "不能进行【同桌】请求！  ", vbInformation
           Exit Sub
        End If
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
            sBoxSite = sFirstSite  '桌号保存
           '显示未消费的桌
            frmCopysite.Show 1
        Exit Sub
        
ERR_HZ:
        MsgBox "对不起，同桌复制错误：   " & vbCrLf & vbCrLf & Err.Description, vbInformation
        Exit Sub
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
   
   Dim lstTmp As ListItem
   Set lstTmp = tmpView.ListItems.Add
       lstTmp.Text = sText1
       lstTmp.SubItems(1) = sText2
       lstTmp.SubItems(2) = sText3
       lstTmp.SubItems(3) = sText4
       lstTmp.SubItems(4) = Format(sText5, "0.00")
       lstTmp.SubItems(5) = Format(sText6, "0.00")
       lstTmp.SubItems(6) = Format(sText7, "0.00")
       
End Sub

Private Sub InsertToPreList(tmpView As ListView, sText1 As String, sText2 As String, sText3 As String _
      , sText4 As String)

   On Error Resume Next
   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.0")
       
End Sub

Private Sub Timer1_Timer()

   If IsRunning = True Then Exit Sub
   
  '给出餐桌的实时状态
   GetSiteStatus
   Screen.MousePointer = 11
  '配置点菜
   ConfigGrid
  '配置预点菜
   ConfigGridPre
 
   Screen.MousePointer = 0
   
End Sub

Private Sub GetSiteStatus()
  
  On Error Resume Next
  
  IsRunning = True
  
 '查询该座位是否能点菜=2时，才可以
  Dim CDB As Connection
  Dim cRS As Recordset
  Set CDB = CreateObject("ADODB.Connection")
  Set cRS = CreateObject("ADODB.Recordset")
      CDB.Open Constr
      cRS.Open "Select * from SiteType Where Class='" & sBoxSite & "'", CDB, adOpenStatic, adLockReadOnly, adCmdText
      If cRS.EOF And cRS.BOF Then
         cRS.Close
         CDB.Close
         Set cRS = Nothing
         Set CDB = Nothing
         lbStatus.Caption = "餐桌号没有找到？ "
         shpCirCle.FillColor = &HFF&
         Exit Sub
      End If
  Select Case cRS("SiteStatus")
   Case 0
     cRS.Close
     CDB.Close
     Set cRS = Nothing
     Set CDB = Nothing
     lbStatus.Caption = "餐桌还没有『开台』"
     shpCirCle.FillColor = &HFF&
     Exit Sub
   Case 1
     cRS.Close
     CDB.Close
     Set cRS = Nothing
     Set CDB = Nothing
     lbStatus.Caption = "餐桌还没有『开台』"
     shpCirCle.FillColor = &HFF&
     Exit Sub
   Case 2
    '点菜开始
     cRS.Close
     CDB.Close
     Set cRS = Nothing
     Set CDB = Nothing
     lbStatus.Caption = "『已经开台』,可以使用。"
     shpCirCle.FillColor = &HC000&
     Exit Sub
   Case 3
     cRS.Close
     CDB.Close
     Set cRS = Nothing
     Set CDB = Nothing
     lbStatus.Caption = "『正在结帐』,不能点菜。"
     shpCirCle.FillColor = &HFF&
     Exit Sub
   Case 4
     cRS.Close
     CDB.Close
     Set cRS = Nothing
     Set CDB = Nothing
     lbStatus.Caption = "『维修中』,不能点菜。"
     shpCirCle.FillColor = &HFF&
     Exit Sub
  End Select
  
  cRS.Close
  CDB.Close
  Set cRS = Nothing
  Set CDB = Nothing
  
End Sub