frmarrearage.frm

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

       
       Exit Sub
CheckOutERR:
   MsgBox "对不起，结帐错误:" & Err.Description, vbCritical
      
End Sub

Private Sub cmdPrint_Click()

 If lstPro.ListItems.Count = 0 Then Exit Sub

'打印列表
    If MsgBox("真的要打印【挂帐单列表】吗？(Y/N)   " & vbCrLf _
         & "请设置打印机的纸张：A4 纵向   " & vbCrLf & vbCrLf _
         & "如果只打印今日挂帐,请按【挂帐单列表】按钮后再打印。   ", vbInformation + vbYesNo, "www.vb-code.net") = vbNo Then
       Exit Sub
    End If
 
    Dim ptGrid As listViewPrint
 
   '建立打印对象
    On Error GoTo Err1
    
    Dim strPageLeft As String
    Dim strPageTop As String
    Dim PageTop As Long
    Dim PageLeft As Long

Set ptGrid = New listViewPrint
    ptGrid.N_Border = 1
    ptGrid.N_Cols = "1,2,3,4,5,6,7,8,9,10,11"
    Set ptGrid.N_Grid = lstPro
    ptGrid.N_TiTle = "【挂帐单列表】"
    ptGrid.N_Head10 = "制表人：" & UserText
    ptGrid.N_Head2 = "制表时间：" & Now
    ptGrid.N_PageLeft = XLeft
    ptGrid.N_PageTop = XTop
    ptGrid.N_PageHeight = 290
    ptGrid.N_PageWidth = 200
    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()
 
  MakeFind = False
  frmSearcharrearage.Show 1
  
  If MakeFind = True Then
     '刷新查询
     '显示消费数据
      DisplayArrearageData
  End If
  
End Sub

Private Sub cmdToday_Click()
 
  If IsSqlDat = True Then
     sFindString = " Where tbdArrearage.MDate>='" & Date & "' And tbdArrearage.MDate<='" & Date & "'"
    Else
     sFindString = " Where tbdArrearage.MDate>=#" & Date & "# And tbdArrearage.MDate<=#" & Date & "#"
  End If
 '显示消费数据
  DisplayArrearageData

End Sub

Private Sub Form_Load()

  frmMain.lbControl = "挂帐管理"
  ArrearageFocus = True
  GetFormSet Me, frmMain
  If IsSqlDat = True Then
     sFindString = " Where tbdArrearage.MDate>='" & (Date - 7) & "' And tbdArrearage.MDate<='" & Date & "'"
    Else
     sFindString = " Where tbdArrearage.MDate>=#" & (Date - 7) & "# And tbdArrearage.MDate<=#" & Date & "#"
  End If
 '显示消费数据
  DisplayArrearageData
  
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
  
 '浏览带
  lstPro.Left = 100
  lstPro.Width = Me.Width - 300
  lstPro.Height = Me.Height - Frame1.Height - 550

  Frame1.Width = Me.Width - 330
  cmdCancel.Left = Me.Width - cmdCancel.Width - 500
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

  frmMain.lbControl = "收银控制中心"
  ArrearageFocus = False
  SaveFormSet Me
  
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 InsertToArrearageList(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, sText11 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)
       lstTmp.SubItems(10) = Trim(sText11)
End Sub

Private Sub DisplayArrearageData()

    On Error GoTo Err_init

    Me.MousePointer = 11
    Dim curCash As Currency, curNumber As Currency
        curCash = 0: curNumber = 0
        
    Dim DB As Connection, EF As Recordset
    Set DB = CreateObject("ADODB.Connection")
    Set EF = CreateObject("ADODB.Recordset")
        DB.Open Constr
       '按日期倒序
        EF.Open "Select tbdArrearage.MRdate,tbdArrearage.MName,tbdArrearage.Mreturn,tbdArrearage.SheelID,tbdArrearage.MID,tbdArrearage.MDate,tbdArrearage.MHour" _
          & ",tbdArrearage.MMinute,tbdArrearage.MRdate,tbdArrearage.MSFAmount,tbdArrearage.MOperator" _
          & ",tbdArrearage.MAmount,tbdmember.Name from tbdArrearage Inner Join tbdMember On " _
          & " tbdArrearage.MID=tbdMember.ID " & sFindString & " Order By tbdArrearage.Mdate Desc", DB, adOpenStatic, adLockReadOnly, adCmdText
          
        Me.MousePointer = 11
        lstPro.Visible = False
        lstPro.ListItems.Clear
        
        If Not (EF.EOF And EF.BOF) Then
           Do While Not EF.EOF
              InsertToArrearageList lstPro, EF("SheelID"), NullValue(EF("MID")), NullValue(EF("Name")), EF("MDate"), EF("MHour"), EF("MMinute"), EF("MAmount") _
                , NullValue(EF("MRDate")), EF("MSFAmount"), NullValue(EF("MOperator")), NullValue(EF("MName"))
              curCash = curCash + EF("MAmount")
              curNumber = curNumber + EF("MSFAmount")
              EF.MoveNext
              DoEvents
           Loop
        End If
        EF.Close
        DB.Close
        Set EF = Nothing
        Set DB = Nothing
        
       '添加合计数据
        InsertToArrearageList lstPro, "", "", "", "【 合 计 】", vbCrLf, "", CStr(curCash) & "元", "", CStr(curNumber) & "元", "", ""
        lstPro.Visible = True
        Me.MousePointer = 0
        
   Exit Sub
Err_init:
   Me.MousePointer = 0
   MsgBox "显示消费数据错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub lstPro_DblClick()

 '双击显示单据
  If lstPro.ListItems.Count = 0 Then Exit Sub
  If lstPro.SelectedItem.Text = "" Then Exit Sub
  
  Call mnuViewArrearage_Click
  
End Sub

Private Sub lstPro_ItemClick(ByVal Item As MSComctlLib.ListItem)
  
  If lstPro.ListItems.Count = 0 Then
     cmdCheckOut.Enabled = False
    Else
     If Item.Text <> "" Then
        If Item.SubItems(8) = "0" Then
          cmdCheckOut.Enabled = True
        Else
         '已经付帐
          cmdCheckOut.Enabled = False
        End If
      Else
        cmdCheckOut.Enabled = False
     End If
  End If

End Sub

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

  If Button <> 2 Then Exit Sub
  
  If lstPro.ListItems.Count = 0 Then Exit Sub
       '所有取消
     If lstPro.SelectedItem.Text = "" Then
        mnuViewArrearage.Enabled = False
        mnuPay.Enabled = False
       Else
        If lstPro.SelectedItem.SubItems(8) = "0" Then
           mnuPay.Enabled = True
         Else
           mnuPay.Enabled = False
        End If
        mnuViewArrearage.Enabled = True
     End If
     
  PopupMenu mnuMenuArrearage
  
End Sub

Private Sub mnuAllArrearage_Click()

  sFindString = ""
 '显示消费数据
  DisplayArrearageData

End Sub

Private Sub mnuFindArrearage_Click()

  Call cmdSearch_Click
  
End Sub

Private Sub mnuMenuArrearage_Click()

If lstPro.ListItems.Count = 0 Then Exit Sub
       '所有取消
     If lstPro.SelectedItem.Text = "" Then
        mnuViewArrearage.Enabled = False
        mnuPay.Enabled = False
       Else
        If lstPro.SelectedItem.SubItems(8) = "0" Then
           mnuPay.Enabled = True
         Else
           mnuPay.Enabled = False
        End If
        mnuViewArrearage.Enabled = True
     End If
  
End Sub

Private Sub mnuPay_Click()

  Call cmdCheckOut_Click
  
End Sub

Private Sub mnuPrintArrearage_Click()

  Call cmdPrint_Click
  
End Sub

Private Sub mnuTodayArrearage_Click()

  If IsSqlDat = True Then
     sFindString = " Where tbdArrearage.MDate>='" & Date & "' And tbdArrearage.MDate<='" & Date & "'"
    Else
     sFindString = " Where tbdArrearage.MDate>=#" & Date & "# And tbdArrearage.MDate<=#" & Date & "#"
  End If
 '显示消费数据
  DisplayArrearageData

End Sub

Private Sub mnuViewArrearage_Click()

  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 mnuWeekArrearage_Click()

  If IsSqlDat = True Then
     sFindString = " Where tbdArrearage.MDate>='" & Date - 7 & "' And tbdArrearage.MDate<='" & Date & "'"
    Else
     sFindString = " Where tbdArrearage.MDate>=#" & Date - 7 & "# And tbdArrearage.MDate<=#" & Date & "#"
  End If
 '显示消费数据
  DisplayArrearageData

End Sub