frmhzsite.frm

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

      EndProperty
      BeginProperty ColumnHeader(8) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Alignment       =   2
         SubItemIndex    =   7
         Text            =   "打折率"
         Object.Width           =   1411
      EndProperty
      BeginProperty ColumnHeader(9) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Alignment       =   1
         SubItemIndex    =   8
         Text            =   "实付金额"
         Object.Width           =   2117
      EndProperty
      BeginProperty ColumnHeader(10) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   9
         Text            =   "营业员"
         Object.Width           =   1587
      EndProperty
      BeginProperty ColumnHeader(11) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   10
         Text            =   "收银员"
         Object.Width           =   1764
      EndProperty
   End
   Begin VB.Menu mnuMenu 
      Caption         =   "控制菜单(&M)"
      Begin VB.Menu mnuView 
         Caption         =   "查看消费单(&View)"
         Shortcut        =   {F4}
      End
      Begin VB.Menu ddd 
         Caption         =   "-"
      End
      Begin VB.Menu mnuDelete 
         Caption         =   "删除消费单(&Delete)"
         Shortcut        =   ^D
      End
      Begin VB.Menu asdfsdfdd 
         Caption         =   "-"
      End
      Begin VB.Menu mnuSearch 
         Caption         =   "详细搜索(&Search)"
         Shortcut        =   {F3}
      End
      Begin VB.Menu mnuAll 
         Caption         =   "显示所有消费单(&ALL)"
         Shortcut        =   ^A
      End
      Begin VB.Menu asdfsdf 
         Caption         =   "-"
      End
      Begin VB.Menu mnuPrintSheet 
         Caption         =   "打印单据"
         Shortcut        =   {F5}
      End
      Begin VB.Menu PrintSmallSheet 
         Caption         =   "打印单据小条"
         Shortcut        =   {F6}
         Visible         =   0   'False
      End
      Begin VB.Menu mnuPrint 
         Caption         =   "打印列表(&Print)"
         Shortcut        =   {F8}
      End
      Begin VB.Menu eeeee 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "关闭返回(&Exit)"
         Shortcut        =   ^X
      End
   End
End
Attribute VB_Name = "frmHZSite"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub cmdAll_Click()

  Call mnuAll_Click
  
End Sub

Private Sub cmdDel_Click()

  Call MnuDelete_Click
  
End Sub

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, "www.vb-code.net") = vbNo Then
         Exit Sub
      End If
 
    Dim ptGrid As listViewPrint
     
    '建立打印对象
    On Error GoTo Err1
    
    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 & "  营业员：" & cmbWaiter.Text & "  收银员：" & UserTxt.Text
        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()

 '显示今日记录
  Dim sTmpSQL As String
      sTmpSQL = ""
 '有指定营业员时
  If Trim(cmbWaiter.Text) <> "" Then
     sTmpSQL = sTmpSQL & " And Waiter='" & Trim(cmbWaiter.Text) & "'"
  End If
 '有指定操作员时
  If Trim(UserTxt.Text) <> "" Then
     sTmpSQL = sTmpSQL & " And CheckOutMan='" & Trim(UserTxt.Text) & "'"
  End If
  
  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 & "'))" & sTmpSQL & ") Order By ID"
     Else
       RefreshGrid " Where (((lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
         & " And  (Date>=#" & dtpStart.Value & "# And Date<=# " & dtpEnd.Value & "#))" & sTmpSQL & ") 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 & "'))" & sTmpSQL & ") Order By ID"
     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 & "#))" & sTmpSQL & ") Order By ID"
    End If
  End If
  
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_Activate()

  frmMain.lbControl.Caption = "按座位汇总消费"

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

  HZSiteFocus = True
  GetFormSet Me, frmMain
  
  dtpStart.Value = Date: dtpEnd.Value = Date
 
 '列表员工姓名
  GetEmployList cmbWaiter
 '写入操作员列表
  WriteEmploy
    
  If IsSqlDat = True Then
     '显示今日记录
     RefreshGrid " Where (lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
       & " And (Date>='" & dtpStart.Value & "' And Date<='" & dtpEnd.Value & "') Order By ID DESC"
   Else
   '显示今日记录
     RefreshGrid " Where (lHour>=" & ftStartHour.Text & " And lHour<=" & ftEndHour.Text & ")" _
       & " And (Date>=#" & dtpStart.Value & "# And Date<=# " & dtpEnd.Value & "#) Order By ID DESC"
  End If
  
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)

  frmMain.lbControl.Caption = "收银控制中心"
  HZSiteFocus = False
  SaveFormSet Me
  
End Sub

Private Sub ftEndHour_Change()

  On Error Resume Next
  
  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 "Order By ID DESC"

End Sub

Private Sub dtpENd_KeyDown(KeyCode As Integer, Shift As Integer)
  
  If KeyCode = 13 Then
     ftEndHour.SetFocus
  End If

End Sub

Private Sub dtpStart_KeyDown(KeyCode As Integer, Shift As Integer)

 If KeyCode = 13 Then
    ftStartHour.SetFocus
 End If
 
End Sub