frmhzname.frm

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

  If ftEndHour.Text = "" Then
     ftEndHour.Text = "0"
     ftEndHour.SelStart = 0
     ftEndHour.SelLength = 1
     Exit Sub
  End If
  If CCur(ftEndHour.Text) > 23 Then
     ftEndHour.Text = 23
     ftEndHour.SelStart = 0
     ftEndHour.SelLength = 2
  End If

End Sub

Private Sub ftStartHour_Change()

  On Error Resume Next
  
  If ftStartHour.Text = "" Then
     ftStartHour.Text = "0"
     ftStartHour.SelStart = 0
     ftStartHour.SelLength = 1
     Exit Sub
  End If
  If CCur(ftStartHour.Text) > 23 Then
     ftStartHour.Text = 23
     ftStartHour.SelStart = 0
     ftStartHour.SelLength = 2
  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
     MsgBox "单据为空,不能查看？  ", vbExclamation
     Exit Sub
  End If
  
  If lstPro.SelectedItem.Text = "" Then
     MsgBox "请选择任一单据后继续？  ", vbExclamation
     Exit Sub
  End If
  
  Load frmConsumeDetail
  frmConsumeDetail.nViewID = CLng(lstPro.SelectedItem.Text)
  frmConsumeDetail.Frame2 = "消费单号【" & lstPro.SelectedItem.Text & "】"
  frmConsumeDetail.Show 1

End Sub

Private Sub lstPro_KeyPress(KeyAscii As Integer)

    If KeyAscii = 13 Then
      Call lstPro_DblClick
    End If
    
End Sub

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

  If Button = 2 Then
    If lstPro.ListItems.Count = 0 Then
       mnuView.Enabled = False
       mnuDelete.Enabled = False
       PopupMenu mnuMenu
       Exit Sub
    End If
    If lstPro.SelectedItem.Text = "" Then
       mnuView.Enabled = False
       mnuDelete.Enabled = False
     Else
       mnuView.Enabled = True
       mnuDelete.Enabled = True
    End If
    PopupMenu mnuMenu
  End If
  
End Sub

Private Sub mnuAll_Click()

 '显示所有消费记录
  RefreshGrid ""

End Sub

Private Sub MnuDelete_Click()

  '删除消费单
  On Error GoTo DelERR
 
  If lstPro.ListItems.Count = 0 Then
     MsgBox "没有内容可以删除？   ", vbInformation
     Exit Sub
  End If
  
  If lstPro.SelectedItem.Text = "" Then
     MsgBox "没有内容可以删除？   ", vbInformation
     Exit Sub
  End If
 
  If DeleteGoto(CLng(Trim(lstPro.SelectedItem.Text))) = True Then
    '刷新记录
        If dtpStart.Value = dtpENd.Value Then
          If IsSqlDat = True Then
             RefreshGrid " Where ((lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
                & " And  (Date>='" & dtpStart.Value & "' And Date<='" & dtpENd.Value & "')) "
           Else
             RefreshGrid " Where ((lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
               & " And  (Date>=#" & dtpStart.Value & "# And Date<=# " & dtpENd.Value & "#)) Order By ID"
          End If
         Else
          '日期不同时  And DDirect=" & (cmbType.ListIndex - 1) & " Order By ID"
           If IsSqlDat = True Then
                RefreshGrid " Where ((lHour>=" & ftStartHour.Text _
                & " And  Date='" & dtpStart.Value & "') OR (Date>'" & dtpStart.Value & "' And Date<'" & dtpENd.Value _
                & "') Or (lHour<=" & ftEndHour.Text & " And Date='" & dtpENd.Value & "'))"
           Else
            'Access数据库
                RefreshGrid " Where ((lHour>=" & ftStartHour.Text _
                & " And  Date=#" & dtpStart.Value & "#) OR (Date>#" & dtpStart.Value & "# And Date<#" & dtpENd.Value _
                & "#) Or (lHour<=" & ftEndHour.Text & " And Date=#" & dtpENd.Value & "#)) Order By ID"
          End If
        End If
  End If
  
 Exit Sub
DelERR:
  MsgBox "不能删除该消费单。  " & vbCrLf & vbCrLf & Err.Description, vbCritical
  Exit Sub
    
End Sub

Private Sub MnuExit_Click()

  Call cmdExit_Click
  
End Sub

Private Sub RefreshGrid(sOrder As String)

 On Error GoTo LoadERR

 Dim DB As Connection
 Dim EF As Recordset
 
 Dim curAmount As Currency   '注入1
 Dim curGet As Currency      '支出0
     curAmount = 0: curGet = 0
 Set DB = CreateObject("ADODB.Connection")
 Set EF = CreateObject("ADODB.Recordset")
     DB.Open Constr
     If chkHZ.Value = vbChecked Then
        '建立汇总
         Dim sTmp As String
         sTmp = "Delete From GatherTodayCust" '清空临时库
         DB.Execute sTmp
         sTmp = "Delete From TodayCustX"
         DB.Execute sTmp
         '按名称汇总
         '汇总到临时库
         'sTmp = "INSERT INTO GathertodayCust SELECT Name AS Name,Unit AS Unit, Price AS Price, Sum(Quanty) AS Quantys,Sum(Amo) As JE, Sum(JGF) AS JGFs, Sum(Amos) AS Amoss From Cust Where SheelID In(Select ID From Site " & sOrder & ") GROUP BY  Name,Unit, Price"
         'DB.Execute sTmp
         'sTmp = "INSERT INTO Todaycustx SELECT Name AS Name, Unit AS Unit, Price AS Price, (GatherTodayCust.Quantys) AS Quanty, (GatherTodayCust.JGFS) AS JGF, (GatherTodayCust.JE) AS Amo,(GatherTodayCust.Amoss) AS Amos FROM GatherTodayCust"
         'DB.Execute sTmp
         'EF.Open "Select * from Todaycustx", DB, adOpenStatic, adLockReadOnly, adCmdText
         EF.Open "SELECT DType as DType,Name AS Name,Unit AS Unit, Price AS Price, Sum(Quanty) AS Quantys,Sum(Amo) As JE, Sum(JGF) AS JGFs, Sum(Amos) AS Amoss From Cust Where SheelID In(Select ID From Site " & sOrder & ") GROUP BY  Dtype,Name,Unit, Price", DB, adOpenStatic, adLockReadOnly, adCmdText
      Else
         EF.Open "Select Cust.SheelID,Cust.DType,Cust.Name,Cust.Unit,Cust.Price,Cust.Quanty,Cust.Amo,Cust.JGF,Cust.Amos" _
           & ",Site.Date from Cust Inner Join Site On Cust.SheelID=Site.ID Where Cust.SheelID In(Select ID From Site " & sOrder & ")", DB, adOpenForwardOnly, adLockReadOnly, adCmdText
     End If
     lstPro.Visible = False
     lstPro.ListItems.Clear
     Me.MousePointer = 11
     Dim bLoad As Boolean
     Dim sTmpType As String
         sTmpType = ""
         
     If Not (EF.EOF And EF.BOF) Then
        Dim ccQuanty As Currency, ccAmount As Currency, ccMoney As Currency, ccJGF As Currency
            ccQuanty = 0: ccAmount = 0: ccMoney = 0: ccJGF = 0
        Dim xccQuanty As Currency, xccAmount As Currency, xccMoney As Currency, xccJGF As Currency
            xccQuanty = 0: xccAmount = 0: xccMoney = 0: xccJGF = 0

        Do While Not EF.EOF
            If chkHZ.Value = vbChecked Then
              ccMoney = ccMoney + EF.Fields("JE")    '总额
              ccAmount = ccAmount + EF("Amoss")        '金额
              ccQuanty = ccQuanty + EF("Quantys")      '数量
              ccJGF = ccJGF + EF("JGFs")               '加工费
             '按菜的类别分类==============================================================================
                    If NullValue(EF("DType")) <> sTmpType Then
                       '如果为第一次时sTmptype="" 不统计
                        If sTmpType <> "" Then
                           '插入小计
                           InsertToHz lstPro, "", "【 小 计 】", "", "", "", Chr(10), CStr(Round(xccQuanty, 2)), CStr(Round(xccMoney, 2)) & "元", _
                                              CStr(xccJGF) & "元", CStr(xccAmount) & "元"
                           xccQuanty = 0: xccAmount = 0: xccMoney = 0: xccJGF = 0
                        End If
                        sTmpType = NullValue(EF("DType"))
                        InsertToHz lstPro, "", "", sTmpType, NullValue(EF("Name")), NullValue(EF("Unit")) _
                              , EF("Price"), EF.Fields("Quantys"), EF.Fields("je"), EF.Fields("JGFs"), EF("Amoss")
                      Else
                       InsertToHz lstPro, "", "", "", NullValue(EF("Name")), NullValue(EF("Unit")) _
                              , EF("Price"), EF.Fields("Quantys"), EF.Fields("je"), EF.Fields("JGFs"), EF("Amoss")
                    End If
                    xccMoney = xccMoney + EF.Fields("Je")    '总额
                    xccAmount = xccAmount + EF("Amoss")        '金额
                    xccQuanty = xccQuanty + EF("Quantys")      '数量
                    xccJGF = xccJGF + EF("JGFs")               '加工费
             '=============================================================================================
              Else
               ccMoney = ccMoney + EF.Fields("Amo")    '总额
               ccAmount = ccAmount + EF("Amos")        '金额
               ccQuanty = ccQuanty + EF("Quanty")      '数量
               ccJGF = ccJGF + EF("JGF")               '加工费
               InsertToHz lstPro, EF.Fields("SheelID"), EF.Fields("Date"), NullValue(EF("DType")), NullValue(EF("Name")), NullValue(EF("Unit")) _
                        , EF("Price"), EF.Fields("Quanty"), EF.Fields("Amo"), EF.Fields("JGF"), EF("Amos")
            End If
            EF.MoveNext
            DoEvents
         Loop
         If sTmpType <> "" Then
           '插入小计
            InsertToHz lstPro, "", "【 小 计 】", "", "", "", Chr(10), CStr(Round(xccQuanty, 2)), CStr(Round(xccMoney, 2)) & "元", _
                       CStr(xccJGF) & "元", CStr(xccAmount) & "元"
         End If
           '添加合计信息
            InsertToHz lstPro, "", "【 合 计 】", "", "", "", Chr(10), CStr(Round(ccQuanty, 2)), CStr(Round(ccMoney, 2)) & "元", _
                      CStr(ccJGF) & "元", CStr(ccAmount) & "元"
     End If
     DB.Close
     Set DB = Nothing
     IsAdd = False
     lstPro.Visible = True
     Me.MousePointer = 0
     
 Exit Sub
LoadERR:
  Me.MousePointer = 0
  MsgBox "安装消费记录出错？" & Err.Description, vbExclamation, "www.vb-code.net"""
  Exit Sub
   
End Sub

'添加到流水帐中
Private Sub InsertToHz(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 _
      , sText10 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) = Trim(sText6)
       lstTmp.SubItems(6) = Trim(sText7)
       lstTmp.SubItems(7) = Trim(sText8)
       lstTmp.SubItems(8) = Trim(sText9)
       lstTmp.SubItems(9) = Trim(sText10)
       
End Sub

Private Sub mnuPrint_Click()
  
  Call cmdPrint_Click
  
End Sub

Private Sub mnuSearch_Click()

  Call cmdSearch_Click
  
End Sub

Private Sub mnuView_Click()

  Call lstPro_DblClick
  
End Sub