frmwastebook.frm

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

      EndProperty
      BeginProperty ColumnHeader(6) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Alignment       =   1
         SubItemIndex    =   5
         Text            =   "实收金额"
         Object.Width           =   1587
      EndProperty
      BeginProperty ColumnHeader(7) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   6
         Text            =   "详细说明"
         Object.Width           =   6350
      EndProperty
      BeginProperty ColumnHeader(8) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   7
         Text            =   "操作员"
         Object.Width           =   1587
      EndProperty
      BeginProperty ColumnHeader(9) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   8
         Text            =   "支付方法"
         Object.Width           =   1764
      EndProperty
   End
End
Attribute VB_Name = "frmWasteBook"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub cmdExit_Click()

    Unload Me
 
End Sub

Private Sub cmdPrint_Click()

    If lstPro.ListItems.Count = 0 Then
       MsgBox "没有打印内容。  ", vbExclamation
       Exit Sub
    End If
    
    '打印列表
      If MsgBox("真的要打印【现金流水帐】列表吗？(Y/N)   " & vbCrLf _
         & "请设置打印： A4纸 纵向    ", vbInformation + vbYesNo, "网维网络软件公司") = vbNo Then
         Exit Sub
      End If
 
    Dim ptGrid As listViewPrint
    Dim sTMp As String
    '建立打印对象
    On Error GoTo Err1
    
    If UserTxt.Text = "" Then
       sTMp = "  操作员：所有"
      Else
       sTMp = "  操作员：" & UserTxt.Text
    End If
    If cmbPayMethod.Text = "" Then
        sTMp = sTMp & "  付款方式：所有"
       Else
        sTMp = sTMp & "   付款方式：" & cmbPayMethod.Text
    End If
    Set ptGrid = New listViewPrint
        ptGrid.N_Border = 1
        ptGrid.N_Cols = "1,2,3,4,5,6,7,8,9"
        Set ptGrid.N_Grid = lstPro
        ptGrid.N_TiTle = "【现金流水帐】"
        ptGrid.N_Head10 = "制表人：" & UserText & sTMp
        ptGrid.N_Head2 = "时间范围：" & dtpStart.Value & " " & ftStartHour.Text & "点 - " & dtpEnd.Value & " " & ftEndHour.Text & "点"
        ptGrid.N_PageLeft = XLeft
        ptGrid.N_PageHeight = 290
        ptGrid.N_PageWidth = 200
        ptGrid.N_PageTop = XTop
        ptGrid.N_RowHeight = 6
        ptGrid.PrintPage
        
        Set ptGrid = Nothing
      
     Exit Sub
Err1:
      MsgBox "对不起,打印列表错误。  " & vbCrLf & vbCrLf & Err.Description, vbInformation
      Exit Sub

End Sub

Private Sub cmdSearch_Click()

  Me.MousePointer = 11
    
  Dim sTMp As String
      If cmbType.ListIndex <> 0 Then
         sTMp = " And (DDirect=" & (cmbType.ListIndex - 1) & ")"
      End If
      If UserTxt.Text <> "" Then
         sTMp = sTMp & " And (DOperator='" & Trim(UserTxt.Text) & "')"
      End If
      If cmbPayMethod.Text <> "" Then
         sTMp = sTMp & " And (tmpStr='" & Trim(cmbPayMethod.Text) & "')"
      End If
  If dtpStart.Value = dtpEnd.Value Then
    If IsSqlDat = True Then
       RefreshGrid " Where ((lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
          & " And (DDate>='" & dtpStart.Value & "' And DDate<='" & dtpEnd.Value & "'))" & sTMp & " Order By ID"
     Else
       RefreshGrid " Where ((lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
         & " And (DDate>=#" & dtpStart.Value & "# And DDate<=# " & dtpEnd.Value & "#))" & sTMp & " Order By ID"
    End If
   Else
    '日期不同时  And DDirect=" & (cmbType.ListIndex - 1) & " Order By ID"
     If IsSqlDat = True Then
        RefreshGrid " Where ((lHour>=" & ftStartHour.Text _
          & " And  DDate='" & dtpStart.Value & "') OR (DDate>'" & dtpStart.Value & "' And DDate<'" & dtpEnd.Value _
          & "') Or (lHour<=" & ftEndHour.Text & " And DDate='" & dtpEnd.Value & "'))" & sTMp & " Order By ID"
     Else
       'Access数据库
        RefreshGrid " Where ((lHour>=" & ftStartHour.Text _
          & " And  DDate=#" & dtpStart.Value & "#) OR (DDate>#" & dtpStart.Value & "# And DDate<#" & dtpEnd.Value _
          & "#) Or (lHour<=" & ftEndHour.Text & " And DDate=#" & dtpEnd.Value & "#))" & sTMp & " Order By ID"
    End If
     
  End If
  
  Me.MousePointer = 0

End Sub

Private Sub dtpEnd_Change()

 If dtpEnd.Value < dtpStart.Value Then
    dtpStart.Value = dtpEnd.Value
 End If
 
End Sub

Private Sub dtpStart_Change()

  If dtpStart.Value > dtpEnd.Value Then
     dtpEnd.Value = dtpStart.Value
  End If
  
End Sub

Private Sub Form_Load()

 On Error GoTo LoadERR
 WasteBookFocus = True
 frmMain.lbControl.Caption = "现金流水帐"
 
 GetFormSet Me, Screen
 Me.MousePointer = 11
 
'最后一周内容
 dtpStart.Value = Date
 dtpEnd.Value = Date
 
 cmbType.ListIndex = 0

'写入操作员列表
 WriteEmploy
'配置付款方式
 ConfigPayMethod
    
 If IsSqlDat = True Then
   If cmbType.ListIndex = 0 Then '无类型时
       RefreshGrid " Where (lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
       & " And (DDate>='" & dtpStart.Value & "' And DDate<='" & dtpEnd.Value & "')  Order By ID"
     Else
       RefreshGrid " Where (lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
       & " And (DDate>='" & dtpStart.Value & "' And DDate<='" & dtpEnd.Value & "')  And DDirect=" & (cmbType.ListIndex - 1) & " Order By ID"
   End If
  Else
   If cmbType.ListIndex = 0 Then '无类型时
       RefreshGrid " Where (lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
       & " And (DDate>=#" & dtpStart.Value & "# And DDate<=# " & dtpEnd.Value & "#)  Order By ID"
     Else
       RefreshGrid " Where (lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
       & " And (DDate>=#" & dtpStart.Value & "# And DDate<=# " & dtpEnd.Value & "#)  And DDirect=" & (cmbType.ListIndex - 1) & " Order By ID"
   End If
 End If
 Me.MousePointer = 0
 
 Exit Sub
LoadERR:
 MsgBox "安装现金流水帐错误：" & Err.Description, vbExclamation, "www.vb-code.net"""
 Me.MousePointer = 0
 Exit Sub
 
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.ScaleWidth - 180
  lstPro.Left = Frame1.Left
  lstPro.Width = Frame1.Width
  lstPro.Height = Me.ScaleHeight - Frame1.Height - 200
  
  'cmdExit.Left = Frame1.Width - cmdExit.Width - 180
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

 WasteBookFocus = False
 frmMain.lbControl.Caption = "收银控制中心"
 
 If Me.WindowState <> 1 Then
    SaveFormSet Me
 End If
 
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
     EF.Open "Select * from tbdWasteBook " & sOrder, DB, adOpenForwardOnly, adLockReadOnly, adCmdText
     Me.MousePointer = 11
     lstPro.Visible = False
     lstPro.ListItems.Clear
     
     Dim bLoad As Boolean
     
     If Not (EF.EOF And EF.BOF) Then
        
        Dim ccQuanty As Currency, ccAmount As Currency, ccMoney As Currency, ccDiscount As Currency
            ccQuanty = 0: ccAmount = 0: ccMoney = 0: ccDiscount = 0

        Do While Not EF.EOF
            
           '支出操作///////////////////////////////////////////////////////////
            If EF.Fields("DDirect") = 0 Then
               ccAmount = ccAmount + EF("DMoney")
               InsertToWastebook lstPro, EF.Fields("ID"), EF.Fields("DDate"), EF("lHour"), EF("lMinute") _
                        , EF.Fields("DMoney"), 0, EF.Fields("DReason"), NullValue(EF.Fields("DOperator")), NullValue(EF("tmpStr"))
              Else
              '注入或收取时======================================================================
              ' If EF("tmpStr") <> "会员卡付" Then               '因为卡付直接从卡中减少。
                ccMoney = ccMoney + EF.Fields("DMoney")
              ' End If
               InsertToWastebook lstPro, EF.Fields("ID"), EF.Fields("DDate"), EF("lHour"), EF("lMinute") _
                        , 0, EF.Fields("DMoney"), EF.Fields("DReason"), NullValue(EF.Fields("DOperator")), NullValue(EF("tmpStr"))
            End If
            EF.MoveNext
            DoEvents
         Loop
        '添加合计信息
         InsertToWastebook lstPro, "", "【 合 计 】", "", "", CStr(Round(ccAmount, 2)) & "元", CStr(Round(ccMoney, 2)) & "元", _
                   "总计：" & CStr(ccMoney - ccAmount) & "元,小计见『消费统计表』", " ", " "
     End If
 
     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 ftEndHour_Change()

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

Private Sub ftEndminute_Change()

  If ftEndminute.Text = "" Then
     ftEndminute.Text = "0"
     ftEndminute.SelStart = 0
     ftEndminute.SelLength = 1
  End If
  
  If CInt(ftEndminute.Text) > 59 Then
     ftEndminute.Text = "59"
     ftEndminute.SelStart = 0
     ftEndminute.SelLength = 2
  End If
  
End Sub

Private Sub ftStartHour_Change()

  If ftStartHour.Text = "" Then
     ftStartHour.Text = "0"
     ftStartHour.SelStart = 0
     ftStartHour.SelLength = 1
  End If
  
  If CInt(ftStartHour.Text) > 23 Then
     ftStartHour.Text = "23"
     ftStartHour.SelStart = 0
     ftStartHour.SelLength = 2
  End If
  
End Sub

Private Sub ftStartMinute_Change()

  If ftStartMinute.Text = "" Then
     ftStartMinute.Text = "0"
     ftStartMinute.SelStart = 0
     ftStartMinute.SelLength = 1
  End If
  
  If CInt(ftStartMinute.Text) > 59 Then
     ftStartMinute.Text = "59"
     ftStartMinute.SelStart = 0
     ftStartMinute.SelLength = 2
  End If
  
End Sub

'添加到流水帐中
Private Sub InsertToWastebook(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)
 
   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)
End Sub

'装载用户名称到登录窗口中
 Private Sub WriteEmploy()
   
   On Error GoTo WriteERR
   
      Dim cnDB As Connection
      Dim cnRS As Recordset
      
      Set cnDB = CreateObject("ADODB.Connection")
      Set cnRS = CreateObject("ADODB.Recordset")
          cnDB.Open Constr
      
       Dim sTMp As String, sID As String
                      
      '如果帐号已经过期、帐号已经锁定时将不显示,永不过期有效
       sTMp = "Select * from Main"
       cnRS.Open sTMp, cnDB, adOpenDynamic, adLockReadOnly, adCmdText
       
       If Not cnRS.EOF Then
          
          Do While Not cnRS.EOF
             If cnRS.EOF Then Exit Do
                sTMp = cnRS("操作员")
               '插入到列表中
                UserTxt.AddItem sTMp
                cnRS.MoveNext
          Loop
          
       End If
       
       cnRS.Close
       cnDB.Close
       Set cnRS = Nothing
       Set cnDB = Nothing
 
    Exit Sub
WriteERR:
    MsgBox "写操作员错误:" & Err.Description, vbCritical & vbCrLf _
       & "请确认是否是数据库没有配置好？   ", vbExclamation
End Sub

Private Sub ConfigPayMethod()

  On Error GoTo GetPaymentERR

  Dim DB As Connection, EF As Recordset, HH As Integer
  Set DB = CreateObject("ADODB.Connection")
      DB.Open Constr
  Set EF = CreateObject("ADODB.Recordset")
      EF.Open "Select * From PayType", DB, adOpenStatic, adLockReadOnly, adCmdText
      
      cmbPayMethod.Clear
      
       Do While Not EF.EOF()
          If Not IsNull(EF.Fields(0)) Then
             cmbPayMethod.AddItem EF.Fields(0).Value
          End If
          EF.MoveNext
       Loop
       EF.Close
       Set EF = Nothing
       DB.Close
       Set DB = Nothing
  
  Exit Sub
GetPaymentERR:
  MsgBox "给出付款方法错误:" & Err.Description, vbCritical
  Exit Sub
 
End Sub