frmcash.frm

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

           MsgBox "只有『会员』才有挂帐资格,否则不能挂帐。   ", vbInformation
           ftCID.SetFocus
           Exit Sub
        End If
       '挂帐客户提醒
        txtSK.Text = "0"
        If MsgBox("请在入帐前将帐单打印出来,否则入帐后将不能打印帐单。" & vbCrLf & vbCrLf _
            & "您现在进行【挂帐操作】,挂帐时实收现金自动变为 0 ？  " & vbCrLf & vbCrLf _
            & "『挂帐』的金额以后在〖挂帐管理】中处理,是否继续。  ", vbInformation + vbYesNo) = vbNo Then Exit Sub
    End If
        
    Dim DB As Connection
    Dim EF As Recordset
    Dim lSheelID As Long
    Set DB = CreateObject("ADODB.Connection")
        DB.Open Constr
        DB.BeginTrans
    
    Set EF = CreateObject("AdODB.Recordset")
      '1检查上台信息，是否有该台
        EF.Open "Select * From tmpSite Where Site='" & sPubSite & "'", DB, adOpenStatic, adLockOptimistic, adCmdText
        If EF.BOF And EF.EOF Then  '没有记录时为0
           lSheelID = 0
           EF.Close
           Set EF = Nothing
           DB.RollbackTrans
           DB.Close
           Set DB = Nothing
           MsgBox "很抱歉，该桌没有消费！  ", vbExclamation
           Exit Sub
         Else
          '当前消费的ID号
           lSheelID = EF.Fields("ID")      '给出使用记录号 ,明细表及菜单号码中使用。
          '更新付款方式
           EF.Fields("tmpStr") = cmbPayMethod.Text '付款方式
           If chkCard.Value = vbChecked Then
              If CCur(ftRemain.Text) >= CCur(txtFK.Text) Then
                 '可以完整支付时
                  EF.Fields("tmpCur") = txtFK.Text       '卡付金额
                Else
                  EF.Fields("tmpCur") = ftRemain.Text    '卡付金额，所有
              End If
           End If
           EF.Update
        End If
        EF.Close
        Set EF = Nothing
        
      '检查是否为共享版
       If IsShare = True Then
          Dim shareRS As Recordset
          Set shareRS = CreateObject("ADODB.Recordset")
              shareRS.Open "Select count(*) from Site", DB, adOpenStatic, adLockReadOnly, adCmdText
              If Not (shareRS.EOF And shareRS.BOF) Then
                 If shareRS(0) > 50 Then
                    DB.RollbackTrans
                    DB.Close
                    Set DB = Nothing
                    MsgBox "试用版仅能添加100条记录,请注册。  " & vbCrLf _
                        & "注册信息请参（系统控制）菜单中的关于与注册。  ", vbInformation
                    Exit Sub
                  Else
                   shareRS.Close
                   Set shareRS = Nothing
                 End If
              Else
                shareRS.Close
                Set shareRS = Nothing
              End If
       End If
       
      '2如果为会员时，记录累计消费，及自动升级提示？
       If Trim(ftCID.Text) <> "" Then
          If chkArrearage.Value = vbChecked Then
             '挂帐时DB为数据库，FtCID为客户编号,0为消费金额,txtFK为挂帐金额
              UpdateGuestLJ DB, Trim(ftCID.Text), 0, CCur(txtFK.Text)
             Else
              UpdateGuestLJ DB, Trim(ftCID.Text), CCur(txtFK.Text), 0
          End If
       End If
       
      '3建立收款表
        If chkArrearage.Value = vbUnchecked Then
            Dim sMemo As String
                If ftCID.Text <> "" Then
                   sMemo = "会员：【" & ftCID.Text & "】消费结帐"
                  Else
                   sMemo = "散客结帐"
                End If
            '更新客户的会员付款
             If chkCard.Value = vbChecked Then
                '建立卡付对帐单=============
                 Dim tmpRemain As Currency
                 If CCur(ftRemain.Text) >= CCur(txtFK.Text) Then
                     tmpRemain = CCur(ftRemain.Text) - CCur(txtFK.Text)
                     InserToCard DB, 0, "消费卡结帐 - " & Date, CCur(txtFK.Text), Trim(ftCID.Text), lSheelID, tmpRemain
                    '---------------------------
                    '有足够金额时
                    '减少卡上金额
                     UpdateRemain DB, Trim(ftCID.Text), tmpRemain
                    '插入剩余现金
                     InserToCash DB, 1, sMemo, CCur(txtFK.Text), Date, "会员卡付"
                    '修改今日与总金额
                     InserTodayCash DB, "会员卡付", CCur(txtFK.Text), Date
                   Else
                    '资金不够时，只能通过其它方法输入
                     tmpRemain = 0
                     InserToCard DB, 0, "消费卡结帐 - " & Date, CCur(ftRemain.Text), Trim(ftCID.Text), lSheelID, tmpRemain
                    '---------------------------
                     '减少卡上金额
                     UpdateRemain DB, Trim(ftCID.Text), tmpRemain
                    '插入剩余现金
                     InserToCash DB, 1, sMemo, CCur(ftRemain.Text), Date, "会员卡付"
                    '修改今日与总金额
                     InserTodayCash DB, "会员卡付", CCur(ftRemain.Text), Date
                    '========补足不够的部分===========================================
                     '插入剩余现金
                     InserToCash DB, 1, sMemo, CCur(txtFK.Text) - CCur(ftRemain.Text), Date, cmbPayMethod.Text
                    '修改今日与总金额
                     InserTodayCash DB, cmbPayMethod.Text, CCur(txtFK.Text) - CCur(ftRemain.Text), Date
                  End If
               Else
                 InserToCash DB, 1, sMemo, CCur(txtFK.Text), Date, cmbPayMethod.Text
                '4修改今日与总金额
                 InserTodayCash DB, cmbPayMethod.Text, CCur(txtFK.Text), Date
             End If
          Else
           '插入挂帐库中。
            InserToArrearage DB, lSheelID, Trim(ftCID.Text), Trim(ftArrearage.Text), CCur(txtFK.Text), Date
           '4修改今日与总金额
            InserTodayCash DB, "挂帐", CCur(txtFK.Text), Date
        End If
        
       '5清台
        Dim sTMp As String
            sTMp = "Update tmpCust Set SheelID=" & lSheelID & " Where Site='" & sPubSite & "'"
            DB.Execute sTMp

       '6替换付款金额
        GetJE DB
        
       '打印函数
       'Call cmdPrint_Click
      
       '保存消费记录
        sTMp = "Insert Into Site Select * From tmpSite Where Site='" & sPubSite & "'"
        DB.Execute sTMp
        sTMp = "Insert Into Cust Select * From tmpCust Where Site='" & sPubSite & "'"
        DB.Execute sTMp
       '清除临时记录
        sTMp = "Delete  From tmpSite Where Site='" & sPubSite & "'"
        DB.Execute sTMp
        sTMp = "Delete  From tmpCust Where Site='" & sPubSite & "'"
        DB.Execute sTMp
       '清除预点内容
        sTMp = "Delete  From tmpBox Where Site='" & sPubSite & "'"
        DB.Execute sTMp
       '清除飞单内容
        sTMp = "Delete  From ptCust Where Site='" & sPubSite & "'"
        DB.Execute sTMp
       '还原餐桌状态
        sTMp = "Update SiteType Set SiteStatus=0 Where Class='" & sPubSite & "'"
        DB.Execute sTMp
        
    DB.CommitTrans
    DB.Close
    Set DB = Nothing
    
    Unload Me
    
    Exit Sub
    
CheckErr:
    MsgBox "结帐发生错误：" & vbCrLf & vbCrLf & Err.Description, vbCritical, vbOKOnly
    On Error Resume Next
    DB.RollbackTrans
    DB.Close
    Set DB = Nothing
    
End Sub

Private Sub cmdPrint_Click()

  '显示打印预览
   frmPreview.Show 1
      
End Sub

Private Function GetSiteID(stmpIds As String) As String
 
   On Error GoTo GetERR
   
   Dim pDB As Connection
   Dim pRS As Recordset
   Dim sTmpx As String
   
   Set pDB = CreateObject("ADODB.Connection")
   Set pRS = CreateObject("ADODB.Recordset")
       pDB.Open Constr
       sTmpx = "SElect * from tmpSite Where Site='" & stmpIds & "'"
       pRS.Open sTmpx, pDB, adOpenStatic, adLockReadOnly, adCmdText
       If pRS.EOF And pRS.BOF Then
          GetSiteID = ""
        Else
          GetSiteID = pRS("ID")
       End If
       
       pRS.Close
       pDB.Close
       Set pRS = Nothing
       Set pDB = Nothing
       
       Exit Function
       
GetERR:
       GetSiteID = ""
       MsgBox "对不起,给出消费单号错误:" & Err.descrition, vbCritical
       Exit Function
       
End Function

Private Sub cmdSelectMember_Click()

    sGuestID = "": sGuestName = ""
    cGuestRemain = 0                  '初始化会员参数
    frmMemberSelect.Show 1
  
    If sGuestID = "" Then
        ftCID.SetFocus
        Exit Sub
      Else
        ftCID.Text = sGuestID
        ftCName.Text = sGuestName
        ftRemain.Text = cGuestRemain
        cmbDZ.Text = GetCustomerRate(sGuestID)
        Already = True
        GetMoneyCount
        txtSK.SetFocus
       '计算打折率
    End If

End Sub

Private Sub GetMoneyCount()

   On Error Resume Next
   If chkCard.Value = vbChecked Then
     '如果卡的金额足够时
      If CCur(ftRemain.Text) > CCur(txtFK.Text) Then
         txtSK.Text = 0
         txtZL.Text = 0
       Else
        '否则补上差额
         txtSK.Text = CCur(txtFK.Text) - CCur(ftRemain.Text)
         txtZL.Text = 0
      End If
     Else
     txtSK.Text = txtFK.Text
  End If

End Sub

Private Sub cmdSmallPrint_Click()
  
 '给出当前座位的ID
  PrintSmallSheet GetSiteID(sPubSite)
  
End Sub

Private Sub Form_Load()

  On Error GoTo CashERR
 
  GetFormSet Me, Screen
 '计算付款金额
  Me.MousePointer = 11
 
 '包厢费与金额
  cJE = 0: cBXF = 0: cRate = 0
  JSAmo = 0: JGAmo = 0: SFAmo = 0: FKAmo = 0
  
  cmbDZ.Text = "100"
 '计算金额,每次重新启动计算机金额
 
  txtBXF.Text = cBXF
  txtJE.Text = cJE
  txtFK.Text = FKAmo
  Already = False
  
 '配置付款方式
  ConfigPayMethod
  
 '是否允许打折
  If AllowDZ = False And UserText <> "超级用户" Then
     cmbDZ.Visible = False
     Label1(1).Visible = False
     Label1(0).Visible = False
  End If
  
 '设置目前餐桌状态
  If SetCashOut(sPubSite, 3) = False Then
     
  End If
  
  Me.MousePointer = 0
 
  Exit Sub
CashERR:
  MsgBox "进入收款系统错误:" & Err.Description, vbCritical
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

  SaveSetting App.EXEName, "Option", "Acount", cmbDZ.ListIndex
  SaveSetting App.EXEName, "Option", "PayMethod", cmbPayMethod.ListIndex
  SaveFormSet Me
  
End Sub

Private Sub ftCID_Change()

  Already = False
  
End Sub

Private Sub ftCID_DblClick()

  cmdSelectMember_Click
 
End Sub

Private Sub ftCID_LostFocus()
  
  '较对会员是否存在
  If Trim(ftCID.Text) <> "" Then
    '如果已经查询时，不必再查询
     If Already = True Then Exit Sub
     If CheckCustomerRate(Trim(ftCID.Text)) = False Then
        cmbDZ.Text = "100"
        ftRemain.Text = "0"
        ftCID.Text = ""
        ftCName.Text = ""
        Already = True
        GetMoneyCount
        Exit Sub
     End If
    '给出打折率
     If AllowDZ = True Or UserText = "超级用户" Then
        cmbDZ.Text = cRate
     End If
     ftCName.Text = sGuestName
     ftRemain.Text = cGuestRemain
     GetMoneyCount
     Already = True
    Else
     cmbDZ.Text = "100"
     ftRemain.Text = "0"
     ftCName.Text = ""
     GetMoneyCount
     Already = False
  End If
   
End Sub

Private Sub ftCName_DblClick()

  cmdSelectMember_Click

End Sub

Private Sub txtFK_Change()

   GetMoneyCount
   
End Sub

Private Sub txtJE_Change()

  On Error Resume Next
  'txtFK.Text = FKAmo + JGAmo + cBXF