frmcash.frm

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

End Sub

Private Sub txtSK_Change()

  On Error Resume Next
  If txtSK.Text = "" Then
      txtSK.Text = "0"
      txtSK.SelStart = 0
      txtSK.SelLength = 1
   End If
   If txtSK.Text = "0" Then
      txtSK.Text = "0"
      txtSK.SelStart = 0
      txtSK.SelLength = 1
   End If
   If txtSK.Text = "." Then
      txtSK.Text = "0."
      txtSK.SelStart = 2
      txtSK.SelLength = 0
  End If
 
 '使用卡时，补上差额
  If chkCard.Value = vbChecked Then
      If CCur(ftRemain.Text) > CCur(txtFK.Text) Then
         '卡内金额足够时
          txtZL.Text = "0": txtSK.Text = "0"
        Else
          txtZL.Text = Round(CCur(txtSK.Text) + CCur(ftRemain.Text) - CCur(txtFK.Text), 0)
      End If
     Else
     txtZL.Text = Round(CCur(txtSK.Text) - CCur(txtFK.Text), 0)
  End If
  
End Sub

Private Sub txtSK_DblClick()

  txtSK.Text = txtFK.Text
  txtSK.SelStart = 0
  txtSK.SelLength = Len(txtSK.Text)
  
  txtSK.SetFocus
  
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
      
       If cmbPayMethod.ListCount > 0 Then
           Dim sPos As Integer
               sPos = GetSetting(App.EXEName, "Option", "PayMethod", 0)
            If sPos > 0 Then
               If sPos > cmbPayMethod.ListCount - 1 Then sPos = cmbPayMethod.ListCount - 1
                  cmbPayMethod.ListIndex = sPos
              Else
               cmbPayMethod.ListIndex = 0
            End If
            SaveSetting App.EXEName, "Option", "PayMethod", cmbPayMethod.ListIndex
        End If
  
  Exit Sub
GetPaymentERR:
  MsgBox "给出付款方法错误:" & Err.Description, vbCritical
  Exit Sub
 
End Sub

Private Sub GetJE(TmpDB As Connection)

  On Error GoTo GetJEERR
  
  Dim JeEf As Recordset
  Dim sTMp As String
      sTMp = "Select * From tmpSite Where Site='" & sPubSite & "'"
  Set JeEf = CreateObject("ADODB.Recordset")
      JeEf.Open sTMp, TmpDB, adOpenStatic, adLockOptimistic, adCmdText
      If Not (JeEf.BOF And JeEf.EOF) Then
         JeEf.Fields("SFAmo") = CCur(txtFK.Text)
         JeEf.Fields("CheckOutMan") = UserText
         JeEf.Fields("Discount") = cmbDZ.Text
         If Trim(ftCID.Text) <> "" Then
            JeEf.Fields("MID") = Trim(ftCID.Text)
         End If
         If chkArrearage.Value = vbChecked Then
            JeEf.Fields("IsArrearage") = 1
           Else
            '正常时
            JeEf.Fields("IsArrearage") = 0
         End If
         JeEf.Update
      End If
      JeEf.Close
  Set JeEf = Nothing
  
  Exit Sub
GetJEERR:
  MsgBox "保存座位消费金额错误:" & Err.Description, vbCritical
  Exit Sub
End Sub

'更新消费金额
Private Sub GetConsum(sType As String, sMID As String, curRate As Integer)

    On Error GoTo Err_DC
    
    Dim hDB As Connection
    Dim hEf As Recordset
    Dim tmpEF As Recordset
    Dim sTMp As String
    Dim cDCJE As Currency, cDCJGF        '点菜金额
     
    Me.MousePointer = 11
    
   '更新座位号消费单
    Set hDB = CreateObject("ADODB.Connection")
        hDB.Open Constr
    Set hEf = CreateObject("ADODB.Recordset")
        hEf.Open "Select tmpsite.SFAmo,tmpsite.DCJE,tmpsite.RJCJE,tmpsite.LJCJE,tmpsite.JSJE," _
            & "tmpsite.JSJGF,tmpsite.LJCJGF,tmpsite.DCJGF,tmpsite.Discount," _
            & "tmpsite.BXF,tmpsite.JEAMO,SiteType.Class,SiteType.Price,SiteType.SupperPrice,SiteType.NightPrice " _
            & " From tmpSite Inner Join SiteType On tmpsite.Site=SiteType.Class " _
            & " Where tmpsite.Site='" & sPubSite & "'", hDB, adOpenStatic, adLockOptimistic, adCmdText
     
     If hEf.BOF And hEf.EOF Then '没有该记录时
        hEf.Close
        Set hEf = Nothing
        hDB.Close
        Set hDB = Nothing
        Me.MousePointer = 0
        cJE = 0: cBXF = 0: cRate = 0
        JSAmo = 0: JGAmo = 0: SFAmo = 0: FKAmo = 0
        MsgBox "没有消费记录,不能汇总消费金额？  " & vbCrLf _
            & "或者其他操作已经结帐。    ", vbInformation
        Exit Sub
      Else
       '1/给出客户的打折率
        'If sMID = "" Then
         cDiscount = CInt(cmbDZ.Text)
        '  Else
           '给出该客户的打折率
        '   cDiscount = GetCustomerRate(sMID)
        'End If
       '2/给出tmpCust的100不打折的金额,应收等于实付,CDiscount=100,加工费不打折
       'A/更新打折内容。
        sTMp = "Update tmpCust Set YFAmo=Amo*" & (cDiscount) / 100 & " Where Site='" & sPubSite & "' And DType In(Select Class from MenuType Where Discount=1)"
        hDB.Execute sTMp
       'B/更新不打折内容
        sTMp = "Update tmpCust Set YFAmo=Amo Where Site='" & sPubSite & "' And DType In(Select Class from MenuType Where Discount=0)"
        hDB.Execute sTMp
       '3/计算金额,不论菜单类型,汇总XX座位的消费金额 ------------------------------------------------------
        sTMp = "Select Sum(YFAmo),Sum(JGF),Sum(Amos) From TmpCust Where Site='" & sPubSite & "'"
        Set tmpEF = CreateObject("ADODB.Recordset")
            tmpEF.Open sTMp, hDB, adOpenStatic, adLockOptimistic, adCmdText
            If tmpEF.BOF And tmpEF.EOF Then
                cDCJGF = 0: cDCJE = 0
                JSAmo = 0
                FKAmo = 0
              Else
                cDCJE = tmpEF.Fields(0)
                cDCJGF = tmpEF.Fields(1)  '点菜加工费
                JSAmo = tmpEF(2)          '消费金额
                FKAmo = tmpEF(0)          '实付金额
            End If
            tmpEF.Close
            Set tmpEF = Nothing
        '-------------------------------------------------------------------------------------------------
        '4/更新当前座位的消费金额。
        '给出当前时间，然后根据当前时间给出包厢费
           Dim tmplHour As Integer
               tmplHour = Hour(Time)
            If tmplHour >= Lunch1 And tmplHour < Lunch2 Then   '中午
               cBXF = hEf("Price")
              ElseIf tmplHour >= Supper1 And tmplHour < Supper2 Then   '下午
               cBXF = hEf("SupperPrice")
              ElseIf tmplHour >= Night1 And tmplHour < NIght2 Then     '晚上
               cBXF = hEf("NightPrice")
              Else
               cBXF = hEf("Price")
            End If
            hEf.Fields("BXF") = cBXF             '包厢费
            hEf.Fields("DCJE") = JSAmo           '点菜金额,已经打折的菜单
            hEf.Fields("DCJGF") = cDCJGF         '加工费
            hEf.Fields("Discount") = cDiscount
            JGAmo = cDCJGF                       '加工费
           '给出金额,界面显示
            cJE = JSAmo + cDCJGF + cBXF
           '应付加上包厢费
            FKAmo = FKAmo + cBXF + cDCJGF
           '金额=消费金额（加工费不打折）+包厢费+DCJGF
            hEf.Fields("JEAmo") = Round((hEf.Fields("DCJE") + hEf.Fields("BXF") + hEf.Fields("DCJGF")), 0)
            hEf.Update
     End If
    
    '5/显示
      hEf.Close
      Set hEf = Nothing
      hDB.Close
      Set hDB = Nothing
      Me.MousePointer = 0
  
 Exit Sub
Err_DC:
  Me.MousePointer = 0
  MsgBox "合计消费金额错误：  " & vbCrLf & vbCrLf & Err.Description, vbInformation
  Exit Sub
  
End Sub

Private Function GetCustomerRate(stmpID As String) As Currency
  
   On Error GoTo CustomerERR
   
   Dim TmpDB As Connection
   Dim tmpRs As Recordset
   Dim sNews As String
   Set TmpDB = CreateObject("ADODB.Connection")
   Set tmpRs = CreateObject("ADODB.Recordset")
       TmpDB.Open Constr
       sNews = "Select tbdMember.DLevel,tbdLevel.DDiscount " _
            & " from tbdMember Inner Join tbdLevel On tbdMember.Dlevel=tbdLevel.ID " _
            & " Where tbdMember.ID='" & stmpID & "'"
       
       tmpRs.Open sNews, TmpDB, adOpenStatic, adLockReadOnly, adCmdText
       If Not (tmpRs.EOF And tmpRs.BOF) Then
          GetCustomerRate = tmpRs("DDiscount")
          Else
          GetCustomerRate = 100
       End If
       tmpRs.Close
       TmpDB.Close
   Set tmpRs = Nothing
   Set TmpDB = Nothing
   
   Exit Function
CustomerERR:
   MsgBox "对不起,给出会员的打折情况错误：" & Err.Description, vbCritical
   GetCustomerRate = 100
   
End Function

Public Sub PrintSheet(nID As String)
     
     On Error GoTo PrintErr
     
     If nID = "" Then
        MsgBox "消费单为空，不能打印？  ", vbInformation
        Exit Sub
     End If
     
    '打印格式
     Dim bExit As Boolean
     Dim sWaiter As String
         sWaiter = GetWaiter(sPubSite)                      '给出营业员

     Dim DB As Connection, EF As Recordset
     Dim sBB As String
     Set DB = CreateObject("ADODB.Connection")
         DB.Open Constr
         sBB = "Delete From prtCust"
         DB.Execute sBB
    '     sBB = "INSERT Into prtCust SELECT DType AS DType, Name AS Name, Unit AS Unit, Price AS Price, Sum(Quanty) AS Quantys, Sum(JGF) AS JGFs, Sum(Amos) AS Amoss From tmpCust WHERE Site='" & sPubSite & "' GROUP BY DType, Name, Unit, Price"
    '     DB.Execute sBB
      Set EF = CreateObject("ADODB.Recordset")
          EF.Open "SELECT DType AS DType, Name AS Name, Unit AS Unit, Price AS Price, Sum(Quanty) AS Quantys, Sum(JGF) AS JGFs, Sum(Amos) AS Amoss From tmpCust WHERE Site='" & sPubSite & "' GROUP BY DType, Name, Unit, Price", DB, adOpenStatic, adLockReadOnly, adCmdText
    '     EF.Open "Select * From prtCust", DB, adOpenStatic, adLockReadOnly, adCmdText
     Dim lPaperCountS As Integer, lPaperCount As Integer
     Dim lCurrent As Integer
         If EF.BOF And EF.EOF Then  '没有记录时 退出
            EF.Close
            Set EF = Nothing
            DB.Close
            Set DB = Nothing
            MsgBox "没有消费记录,不能打印。   ", vbExclamation
            Exit Sub
          Else
            lPaperCount = 0
            Do While Not EF.EOF
               lPaperCount = lPaperCount + 1
               EF.MoveNext
            Loop
            EF.MoveFirst
         End If
         
       '计算总页数
        lPaperCountS = lPaperCount / nPrintLine
        If (lPaperCount Mod nPrintLine) <> 0 And (lPaperCount > nPrintLine) Then '正除时不加0
           lPaperCountS = lPaperCountS + 1
        End If
        If lPaperCountS = 0 Then
           lPaperCountS = lPaperCountS + 1
        End If
          
          Dim x As Integer
          Dim sPN As String
          Dim cDJ As String
          Dim lSL As String
          Dim cJE As String
          Dim cDW As String
          Dim H As Integer
          Dim cJGF As String
          Dim sType As String '类型
          Dim sType1 As String '类型
        '开始打印
         Printer.ScaleMode = 6 'mm
         
   For x = 1 To lPaperCountS
      
         '打印单位名称
          Printer.FontSize = 24
          Printer.FontName = "黑体"
          Printer.FontBold = True
          Printer.CurrentX = ((110 - (Printer.TextWidth(sUnit))) / 2) + 8
          Printer.CurrentY = XTop + 8
         'NoTitle为不打印标题，客户可自行给出
         'NoTitle=1 Or -1
          If NoTitle = False Then
             Printer.Print sUnit
          End If
          Printer.FontSize = 9
          Printer.FontName = "黑体"
          Printer.FontBold = True
          Printer.CurrentX = 8 + XLeft
          Printer.CurrentY = 26 + XTop
          Printer.Print "单号:" & nID
                    
          If chkArrearage.Value = vbChecked Then
            '打印挂帐
             Printer.CurrentX = 42 + XLeft
             Printer.CurrentY = 26 + XTop
             Printer.Print "挂帐"
           Else
             Printer.CurrentX = 42 + XLeft
             Printer.CurrentY = 26 + XTop
             Printer.Print "结帐:" & cmbPayMethod.Text
          End If
          Printer.CurrentX = 75 + XLeft
          Printer.CurrentY = 26 + XTop
          Printer.Print "日期:" & Format(Date, "Long Date")
         '桌号
          Printer.CurrentX = 8 + XLeft
          Printer.CurrentY = 32 + XTop
          Printer.Print "桌号:" & sPubSite
         '会员信息
          If Trim(ftCID.Text) <> "" And Trim(ftCName.Text) <> "" Then
             Printer.CurrentX = 42 + XLeft
             Printer.CurrentY = 32 + XTop
             Printer.Print "会员:" & ftCID.Text
             Printer.CurrentX = 75 + XLeft
             Printer.CurrentY = 32 + XTop
             Printer.Print "姓名:" & ftCName.Text
          End If
         '打印菜单标题
          Printer.CurrentX = 8 + XLeft
          Printer.CurrentY = 40 + XTop
          Printer.FontBold = False
          Printer.Font = "宋体"