frmcustomerform.frm

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

     bDel = True
     Exit Sub
  End If
  If KeyCode = 46 Then  '删除
     bDel = True
     cmbSite.SelText = ""
     Exit Sub
  End If
  
  bDel = False
 
End Sub


Private Sub cmdChange_Click()
 
  If Trim(cmbSite) = "" Then
       MsgBox "座位为空不能继续？   ", vbInformation
       cmbSite.SetFocus
       Exit Sub
  End If
  
  ChangeIt Trim(cmbSite.Text)
  cmbSite.SetFocus
  
End Sub

Private Sub cmdClean_Click()

  If Trim(cmbSite) = "" Then
       MsgBox "座位为空不能继续？   ", vbInformation
       cmbSite.SetFocus
       Exit Sub
  End If
  
  If MsgBox("【" & cmbSite.Text & "】真的要清台吗（Y/N）。" & vbCrLf & vbCrLf & "清台后，所有点菜内容将删除？", vbInformation + vbYesNo + vbDefaultButton2) = vbNo Then Exit Sub
  
  On Error GoTo CleanErr
  
 '清台操作
  Dim DB As Connection
  Dim sTMp As String
  Set DB = CreateObject("ADODB.Connection")
      DB.ConnectionString = Constr
      DB.Open
      DB.BeginTrans
     '清除点菜明细
      sTMp = "Delete from TmpCust Where Site='" & cmbSite.Text & "'"
      DB.Execute sTMp
     '清除座位信息
      sTMp = "Delete from TmpSite Where Site='" & cmbSite.Text & "'"
      DB.Execute sTMp
     '清除包厢点菜内容
      sTMp = "Delete from TmpBox Where Site='" & cmbSite.Text & "'"
      DB.Execute sTMp
     '清除飞单内容
      sTMp = "Delete from ptCust Where Site='" & cmbSite.Text & "'"
      DB.Execute sTMp
     '恢复餐桌状态,为空闲,只有上台或结帐时，才能清台
      sTMp = "Update SiteType Set SiteStatus=0 Where Class='" & cmbSite.Text & "' And (SiteStatus>=2 And SiteStatus<=3)"
      DB.Execute sTMp
      DB.CommitTrans
      DB.Close
      Set DB = Nothing
      
 '清除当前
  MsgBox "清台完毕！", vbInformation
  
 '刷新当前台的内容
  ConfigGrid
 '给出座位取焦
  cmbSite.SetFocus
  
  Exit Sub
CleanErr:
  MsgBox "清台错误:" & Err.Description, vbCritical
  On Error Resume Next
  DB.RollbackTrans
  DB.Close
  Set DB = Nothing
  Exit Sub

End Sub

Private Sub cmdCopy_Click()
 
   If Trim(cmbSite) = "" Then
       MsgBox "座位为空不能继续？   ", vbInformation
       cmbSite.SetFocus
       Exit Sub
  End If
 
 CopyIt Trim(cmbSite.Text)
 cmbSite.SetFocus
 
End Sub

Private Sub cmdDC_Click()

  On Error GoTo ERR_HZ
 
  sPubSite = Trim(cmbSite.Text)  '座位号
   
  If sPubSite = "" Then
       MsgBox "座位为空不能继续？   ", vbInformation
       cmbSite.SetFocus
       Exit Sub
  End If
 
  frmDC.Show 1
 
 '查看是否点菜
  SaveSheet

 '刷新菜单列表
  ConfigGrid
  
 '给出座位焦点
  cmbSite.SetFocus
 
 Exit Sub
ERR_HZ:
 MsgBox "点菜错误：   " & vbCrLf & vbCrLf & Err.Description, vbInformation
 Exit Sub
End Sub

Private Sub SaveSheet()
   
   On Error GoTo SaveERR
   SaveFormSet Me
   
 '判断该桌是否已经点菜,如果有上台成功
 '查询是否已经建立
   Dim DB As Connection
   Dim EF As Recordset
   Dim sTMp As String
   
   Set DB = CreateObject("AdODb.Connection")
       DB.Open Constr
   Set EF = CreateObject("ADODB.Recordset")
       sTMp = "Select * from tmpCust Where Site='" & sPubSite & "'"
       EF.Open sTMp, DB, adOpenStatic, adLockReadOnly, adCmdText
      '没有点菜时，返回===============================================
       If EF.EOF And EF.BOF Then
          EF.Close
          DB.Close
          Set EF = Nothing
          Set DB = Nothing
          Exit Sub
       End If
       EF.Close
      '否则有点菜时，建立上台标记/////////////////////////////////////
       sTMp = "Select * from tmpSite Where Site='" & sPubSite & "'"
       EF.Open sTMp, DB, adOpenStatic, adLockOptimistic, adCmdText
      '还没有建立上台记录时
        If EF.EOF And EF.BOF Then
           EF.AddNew
           EF.Fields("ID") = GetFixNo("座位号")
           EF.Fields("CheckOutMan") = UserText
           EF.Fields("Site") = sPubSite
           EF.Fields("Date") = Date
           EF.Fields("lHour") = Hour(Time)              '给出小时
           EF.Fields("lMinute") = Minute(Time)          '给出分
           EF.Fields("Waiter") = sTmpWaiter             '服务员
           EF.Update
          '显示当前台已经上台
           sTMp = "Update SiteType Set SiteStatus=2 Where Class='" & sPubSite & "'"
           DB.Execute sTMp
          Else
           '更新服务员
            EF.Fields("Waiter") = sTmpWaiter
            EF.Update
        End If
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
                
  Exit Sub
SaveERR:
   MsgBox "保存上台信息错误:" & Err.Description, vbCritical
 
End Sub

Private Sub cmdPast_Click()
 
    If Trim(cmbSite) = "" Then
       MsgBox "座位为空不能继续？   ", vbInformation
       cmbSite.SetFocus
       Exit Sub
    End If
  
    Dim DB As Connection, EF As Recordset
    Set DB = CreateObject("ADODB.Connection")
        DB.Open Constr
    Set EF = CreateObject("ADODB.Recordset")
        EF.Open "Select * From tmpCust Where Site='" & Trim(cmbSite.Text) & "'", DB, adOpenStatic, adLockReadOnly, adCmdText
  ' 没有数据
    If EF.EOF And EF.BOF Then
       EF.Close
       Set EF = Nothing
       DB.Close
       Set DB = Nothing
       MsgBox "对不起，该桌没有消费不能结帐？   ", vbInformation
       cmbSite.SetFocus
       Exit Sub
    End If
    EF.Close
    Set EF = Nothing
    DB.Close
    Set DB = Nothing
    
   '显示结帐内容
    frmCash.Show 1
    
    ConfigGrid
    cmbSite.SetFocus
    
End Sub

Private Sub Form_Activate()

   Screen.MousePointer = 11
  '配置类别
   ConfigGrid
  
  '配置座位
   ConfigSite
   Screen.MousePointer = 0
   
   If sInfoSite <> "" Then
      cmbSite.Text = sInfoSite
   End If
   cmbSite.SetFocus
  
End Sub


Private Sub Form_Load()
  
  On Error GoTo Err_Load
  GetFormSet Me, Screen
  CustFocus = True
  
 '配置菜单分类表
  ConfigType
  frmMain.lbControl.Caption = "客人上台"
  
  Exit Sub
Err_Load:
 MsgBox "表单加载错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub Form_Resize()

  On Error Resume Next
  If Me.WindowState = 1 Then Exit Sub
       
    If Me.WindowState = 0 Then
       Me.Move 1, 1, frmMain.Width - (frmMain.picTool.Width + 200), frmMain.Height - (frmMain.picADV.Height + 1150)
    End If
       
     Frame1.Width = Me.Width - 260
     Frame1.Height = Me.Height - Frame2.Height - 800
     Strip1.Width = Frame1.Width
     lstPro.Height = Frame1.Height - 250
     lstPro.Width = Frame1.Width - 150
     Frame2.Width = Frame1.Width
     cmdCancel.Left = Me.ScaleWidth - cmdCancel.Width - 300
     
End Sub

Private Sub Form_Unload(Cancel As Integer)

 CustFocus = False
 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
   
       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='" & sPubSite & "'"
      Else
         sSQL = "Select * From tmpCust Where Site='" & sPubSite & "'"
    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
  
        Exit Sub
Err_init:
 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 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 Strip1_Click()
  
  '选择类别
  sCustType = Strip1.SelectedItem.Key
  ConfigGrid

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
    '直接指向座位号
     If cmbSite.ListCount > 1 Then
        If sInfoSite <> "" Then
           cmbSite.ListIndex = SendMessage(cmbSite.Hwnd, CB_FINDSTRING, -1, ByVal sInfoSite)
         Else
           cmbSite.ListIndex = 0
        End If
     End If
     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
            sPubSite = 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